[Solved] Compare two sheets and find missing and Duplicate to another sheet
- Thread starter john7777
- Start date
Hello John,
Thank you for sharing your experience with us. Today, I am going to help you write a VBA code that compares the value of 2 sheets and finds the missing and duplicate values in another sheet.
Before going there, read the below article to learn 7 suitable methods to get the missing data after comparison. You will also get an idea of what we are actually doing:
See what you looking for? If not then I have an alternative VBA code that will be more suitable in your case.
Code:
Sub MacroCompare()
'ExcelDemy Product
Dim ws1 As Worksheet, ws2 As Worksheet, wsResult As Worksheet
Dim dict1 As Object, dict2 As Object
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Dim cell As Range
Dim key As Variant
' Set the worksheets you want to compare
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
' Create a new worksheet to store the results
Set wsResult = ThisWorkbook.Sheets.Add
wsResult.Name = "See Result"
' Initialize collections to store missing and duplicate values
Dim missingColumn1 As Collection, missingColumn2 As Collection
Set missingColumn1 = New Collection
Set missingColumn2 = New Collection
Dim duplicateColumn As Collection
Set duplicateColumn = New Collection
' Loop through the first sheet and add values to dict1
For Each cell In ws1.Range("B1:B" & ws1.Cells(Rows.Count, "B").End(xlUp).Row)
key = cell.Value
If Not dict1.Exists(key) Then
dict1.Add key, 1
Else
dict1(key) = dict1(key) + 1
End If
Next cell
' Loop through the second sheet and add values to dict2
For Each cell In ws2.Range("A1:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
key = cell.Value
If Not dict2.Exists(key) Then
dict2.Add key, 1
Else
dict2(key) = dict2(key) + 1
End If
Next cell
For Each key In dict1.Keys
If Not dict2.Exists(key) Then
missingColumn1.Add key
End If
Next key
For Each key In dict2.Keys
If Not dict1.Exists(key) Then
missingColumn2.Add key
End If
Next key
' Find duplicate values in both sheets and add them to duplicateColumn
For Each key In dict1.Keys
If dict2.Exists(key) Then
Dim count1 As Long, count2 As Long
count1 = dict1(key)
count2 = dict2(key)
If count1 > 0 And count2 > 0 Then
Dim minCount As Long
minCount = WorksheetFunction.Min(count1, count2)
For i = 1 To minCount
duplicateColumn.Add key
Next i
End If
End If
Next key
' Write missing values in Sheet2 to the result sheet
wsResult.Cells(1, 1).Value = "Missing Values in Sheet2"
Dim rowIndex As Long
rowIndex = 2
For Each key In missingColumn1
wsResult.Cells(rowIndex, 1).Value = key
rowIndex = rowIndex + 1
Next key
' Write missing values in Sheet1 to the result sheet
wsResult.Cells(1, 2).Value = "Missing Values in Sheet1"
rowIndex = 2
For Each key In missingColumn2
wsResult.Cells(rowIndex, 2).Value = key
rowIndex = rowIndex + 1
Next key
' Write duplicate values to the result sheet under "Duplicate Values" column
wsResult.Cells(1, 3).Value = "Duplicate Values"
rowIndex = 2
For Each key In duplicateColumn
wsResult.Cells(rowIndex, 3).Value = key
rowIndex = rowIndex + 1
Next key
' Clean up
Set dict1 = Nothing
Set dict2 = Nothing
Set missingColumn1 = Nothing
Set missingColumn2 = Nothing
Set duplicateColumn = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set wsResult = Nothing
MsgBox "Comparison completed!", vbInformation
End SubThe MacroCompare compares data between Sheet1 and Sheet2 and presents the results in a new sheet. It uses two scripting dictionaries (dict1 and dict2) to keep track of unique values in each sheet. Finally, it creates a new sheet See Result to display the results and provides a completion message with an MsgBox like below.
I have attached my working workbook. Please practice and let us know if it works for you.
Regards,
Yousuf Shovon
Thank you for your kind help and tutorial link you you given. I checked that link and very helpful.
The given VBA, did it compare B and C column ie. Item and quantity. If sheet1 Item and Quantity is matching Sheet2 that is not Duplicate. That item may differ.
If we want to compare with A,B,C column whether it has data on then how to change the code.
Both sheet's B and C column matching then it is not Duplicate.
The given VBA, did it compare B and C column ie. Item and quantity. If sheet1 Item and Quantity is matching Sheet2 that is not Duplicate. That item may differ.
If we want to compare with A,B,C column whether it has data on then how to change the code.
Both sheet's B and C column matching then it is not Duplicate.
Hello John,
Thanks for your feedback! Yes, you got that right. The previous code compared only the items of the 2 sheets as I thought. If you want to change the comparison ranges, we can modify the code for you.
Can you specify your requirements one more time? For instances:
- Do we get the missing values based on Sheet1 or Sheet2? i.e. There are data in Sheet1 but not in Sheet2 or vice versa?
- How do you want to see the output in the new sheet? Is it in a single column or multiple separate columns?
Again, thank you for your appreciation and feedback. Best Regards!
Thanks for your reply and help.
We need to get missing values based on Sheet1, ie Data in shee1 but not in Sheet2, and duplicate from both Sheets
Output is same as in result sheet (See Result) in single sheet with Date , item quantity (A,B,C ) column ie Missing Value in Sheet2, Duplicate Values in both sheet
Hello John,
Thanks for your thorough explanation. I think this is the code you want:
Code:
Option Explicit
Sub CompareData()
Dim wbk As Workbook
Dim wshMyData As Worksheet, wshBrokersData As Worksheet, wshResult As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim sTmp As String
Dim cell As Range
Dim dict1 As Object, dict2 As Object
Dim key As Variant
On Error Resume Next
Set wbk = ThisWorkbook
Set wshResult = wbk.Worksheets.Add(After:=wbk.Sheets(wbk.Sheets.Count))
wshResult.Name = "Result"
On Error GoTo Err_CompareData
Set wshMyData = wbk.Worksheets("Sheet1")
Set wshBrokersData = wbk.Worksheets("Sheet2")
' Create dictionaries to store data from both sheets
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
' Populate dict1 with data from Sheet1
For Each cell In wshMyData.Range("A1:C275")
key = cell.Value
dict1(key) = dict1(key) + 1
Next cell
' Populate dict2 with data from Sheet2
For Each cell In wshBrokersData.Range("A1:C275")
key = cell.Value
dict2(key) = dict2(key) + 1
Next cell
' Write missing values from Sheet2 to Result sheet in columns A, B, C
k = 1
For Each key In dict1.Keys
If Not dict2.Exists(key) Then
k = k + 1
wshResult.Cells(k, 1).Value = key
wshResult.Cells(k, 2).Value = key.Offset(0, 1).Value
wshResult.Cells(k, 3).Value = key.Offset(0, 2).Value
End If
Next key
' Write duplicate values to Result sheet in columns D, E, F
k = 1
For Each key In dict1.Keys
If dict2.Exists(key) Then
k = k + 1
wshResult.Cells(k, 4).Value = key
wshResult.Cells(k, 5).Value = key.Offset(0, 1).Value
wshResult.Cells(k, 6).Value = key.Offset(0, 2).Value
End If
Next key
' Autofit columns
wshResult.Columns.AutoFit
Exit_CompareData:
On Error Resume Next
Set wshMyData = Nothing
Set wshBrokersData = Nothing
Set wshResult = Nothing
Set wbk = Nothing
Set dict1 = Nothing
Set dict2 = Nothing
Exit Sub
Err_CompareData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_CompareData
End SubThis code will return the missing values of Sheet2 in Column A of Result sheet and duplicate values in Column B of the same sheet.
I am attaching the workbook. Let me know if you need further assistance. Best Regards!
amjadinsaudia
New member
Hi John
I need to filter records based on a value.
Records to be filter are around 200 and sum of few records will bring required total value.
Example data:
I need to filter out records from above list for a value of 1956.16 which is total of last three records.
Any formula or tick to do this.
An early response is appreciated.
I need to filter records based on a value.
Records to be filter are around 200 and sum of few records will bring required total value.
Example data:
| 2966.84 |
| 217.36 |
| 7670.51 |
| 19167.4 |
| 9357.28 |
| 2646.18 |
| 1412.78 |
| 108.68 |
| 434.7 |
I need to filter out records from above list for a value of 1956.16 which is total of last three records.
Any formula or tick to do this.
An early response is appreciated.
Thankyou for reply and help.
1st The code which you given not working, I download the attached file which is working but duplicates value of both sheet1 and Sheet2 comes together. Also Date columns of Duplicate value comes between missing items Column A. I would like to have the report as the attached file, can you help me to provide a report as per the attached format. Hoping you may help regarding this matter.
Thanks in advance
Last edited:
Hello John,
I apologize for the misunderstanding. It is now clear that you want the duplicate values of each sheet on their respective sheets. Thanks for your expected outcome sheet.
You can try this code instead:
Code:
Option Explicit
Sub Compare_Without_Formulas()
'An ExcelDemy Product
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("Sheet1") '<-- Change sheet names to suit
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Expected Result")
Dim LRow1 As Long, LRow2 As Long
Dim i As Long, j As Long
Dim cellValue As Variant
Dim found As Boolean
Dim missingValues As String
Dim duplicateValuesSheet1 As String, duplicateValuesSheet2 As String
Dim dictSheet1 As Object, dictSheet2 As Object
Dim outputRow As Long
' Clear existing data in the result sheet
ws3.Cells.Clear
' Find the last rows in Sheet1 and Sheet2
LRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
LRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
' Initialize the output row
outputRow = 3
' Check for missing values in Sheet1 but not in Sheet2
For i = 2 To LRow1
cellValue = ws1.Cells(i, 2).Value
found = False
For j = 1 To LRow2
If ws2.Cells(j, 1).Value = cellValue Then
found = True
Exit For
End If
Next j
If Not found Then
ws3.Cells(outputRow, 2).Value = cellValue
outputRow = outputRow + 1
End If
Next i
If outputRow = 3 Then
ws3.Cells(3, 2).Value = "no missing values found"
End If
' Check for duplicates in Sheet1
outputRow = 3
Set dictSheet1 = CreateObject("Scripting.Dictionary")
For i = 2 To LRow1
cellValue = ws1.Cells(i, 2).Value
If dictSheet1.Exists(cellValue) Then
ws3.Cells(outputRow, 5).Value = cellValue
outputRow = outputRow + 1
Else
dictSheet1(cellValue) = 1
End If
Next i
If outputRow = 3 Then
ws3.Cells(3, 5).Value = "no duplicates found"
End If
' Check for duplicates in Sheet2
outputRow = 3
Set dictSheet2 = CreateObject("Scripting.Dictionary")
For i = 1 To LRow2
cellValue = ws2.Cells(i, 1).Value
If dictSheet2.Exists(cellValue) Then
ws3.Cells(outputRow, 8).Value = cellValue
outputRow = outputRow + 1
Else
dictSheet2(cellValue) = 1
End If
Next i
If outputRow = 3 Then
ws3.Cells(3, 8).Value = "no duplicates found"
End If
End SubNote: Make sure your file has Sheet1, Sheet2 and Expected Result sheets present. Also, the code output varies from your expected output a little.
I am attaching the workbook. Please, do not hesitate if you need any additional assistance. Thank you for staying in touch. I believe we will get through this problem soon.
Regards.
Hello John,
This is an alternative VBA code to find the missing and duplicate data. The code also puts column headers in the output sheet as you asked.
Code:
Sub FindMissingDuplicates()
'An ExcelDemy Product
Dim sourceSheet As Worksheet, targetSheet As Worksheet, resultSheet As Worksheet
Set sourceSheet = Worksheets("Sheet1") 'Change sheet names if required here
Set targetSheet = Worksheets("Sheet2")
Set resultSheet = Worksheets("Expected Result")
' Add headers in the output sheet
resultSheet.Range("A2").Value = "Date"
resultSheet.Range("B2").Value = "Item"
resultSheet.Range("C2").Value = "Quantity"
resultSheet.Range("D2").Value = "Date"
resultSheet.Range("E2").Value = "Item"
resultSheet.Range("F2").Value = "Quantity"
resultSheet.Range("G2").Value = "Date"
resultSheet.Range("H2").Value = "Item"
resultSheet.Range("I2").Value = "Quantity"
resultSheet.Range("A1:C1").Merge
resultSheet.Range("A1").Value = "Missing Values in Sheet2"
resultSheet.Range("D1:F1").Merge
resultSheet.Range("D1").Value = "Duplicate Values in Sheet1"
resultSheet.Range("G1:I1").Merge
resultSheet.Range("G1").Value = "Duplicate Values in Sheet2"
' Clear existing contents in output columns
With resultSheet
.Range("B3:B" & Application.Max(.Cells(.Rows.Count, "B").End(xlUp).Row, 3)).ClearContents
.Range("E3:E" & Application.Max(.Cells(.Rows.Count, "E").End(xlUp).Row, 3)).ClearContents
.Range("H3:H" & Application.Max(.Cells(.Rows.Count, "H").End(xlUp).Row, 3)).ClearContents
End With
Dim sourceData, targetData, missingData
Dim i As Long, j As Long
sourceData = sourceSheet.Range("B1", sourceSheet.Cells(Rows.Count, "B").End(xlUp))
targetData = targetSheet.Range("A1", targetSheet.Cells(Rows.Count, "A").End(xlUp))
ReDim missingData(1 To UBound(sourceData, 1), 1 To 1)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(sourceData, 1)
.Item(sourceData(i, 1)) = Empty
Next i
For i = 1 To UBound(targetData, 1)
If Not .exists(targetData(i, 1)) Then
j = j + 1
missingData(j, 1) = targetData(i, 1)
End If
Next i
End With
resultSheet.Range("B3").Resize(j).Value = missingData
Dim lastRow As Long, criteriaRange As Range, copyToRange As Range
lastRow = sourceSheet.Cells(Rows.Count, "B").End(xlUp).Row
Set copyToRange = resultSheet.Range("E3")
With sourceSheet.Range("B1:B" & lastRow)
Set criteriaRange = .Offset(, .Columns.Count + 1).Resize(2, 1)
criteriaRange.Cells(2, 1).Formula = "=COUNTIF(B2:B" & lastRow & ",B2)>1"
.AdvancedFilter xlFilterCopy, criteriaRange, copyToRange, 1
sourceSheet.Rows(1).Delete
End With
criteriaRange.Cells(1).Resize(2, 1).ClearContents
resultSheet.Range("E3").Delete xlUp
lastRow = targetSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set copyToRange = resultSheet.Range("H3")
With targetSheet.Range("A1:A" & lastRow)
Set criteriaRange = .Offset(, .Columns.Count + 1).Resize(2, 1)
criteriaRange.Cells(2, 1).Formula = "=COUNTIF(A2:A" & lastRow & ",A2)>1"
.AdvancedFilter xlFilterCopy, criteriaRange, copyToRange, 1
targetSheet.Rows(1).Delete
End With
criteriaRange.Cells(1).Resize(2, 1).ClearContents
resultSheet.Range("H3").Delete xlUp
End SubAfter you have found the missing and duplicate values, these blogs will help you to deal with them:
Let me know if it works for you. Cheers!
Thanks for all the help you provide regarding this question.
As per the report , we mentioned Date, Item , Quantity for each reports,
| ie Missing Values in Sheet2, Duplicate Value in Sheet1, Duplicate values in Sheet2. |
Thank you if you can do it for me
Thank you for your words of appreciation!
Do you want to list every occurrence of the duplicated item from the source sheet? The reason I ask is that using Hercules Sparx 2.0 RF 24" Black as an example, there are 3 instances of that item on sheet 1 - only the second one has a date, the first and third instances have quantities of 6, the second has a quantity of 4. Which instance would you want, or all three?
And, how exactly do you want to show that? In another column on the expected results sheet?
For now, you can try this code for the column order which I thought a bit logical:
Code:
Option Explicit
Sub Compare2Sheets()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, LRow As Long
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Expected Result")
If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
'Clear any existing results
LRow = Application.Max(ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row, 3)
ws3.Range("A3:Z" & LRow).ClearContents
'Get the data missing on sheet 2
Dim a, b, c, d, x
Dim i As Long, j As Long
a = ws1.Range("B1", ws1.Cells(Rows.Count, "B").End(xlUp))
b = ws2.Range("A1", ws2.Cells(Rows.Count, "A").End(xlUp))
ReDim c(1 To UBound(a, 1), 1 To 1)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(a, 1)
.Item(a(i, 1)) = Empty
Next i
For i = 1 To UBound(b, 1)
If Not .exists(b(i, 1)) Then
j = j + 1
c(j, 1) = b(i, 1)
End If
Next i
End With
ws3.Range("A3").Resize(j).Value = c
'Get the duplicates on sheet 1
With ws1
.Activate
.Rows(1).Insert
.Range("A1:E1").Value = Array("Date", "Item", "Qty", "Row", "Count")
End With
LRow = ws1.Cells(Rows.Count, "B").End(xlUp).Row
With ws1.Range("D2:D" & LRow)
.Value = Evaluate("Row(" & .Address(, , , 1) & ")")
End With
With ws1.Range("E2:E" & LRow)
.Value = Evaluate("Countif(B2:B" & LRow & "," & .Offset(, -3).Address(, , , 1) & ")")
End With
With ws1.Range("A1").CurrentRegion
.AutoFilter 5, ">1"
If .SpecialCells(xlCellTypeVisible).Address <> .Rows(1).Address Then
.Offset(1).Resize(, 4).Copy ws3.Range("D3")
End If
.AutoFilter
.Range("D:E").ClearContents
.Rows(1).Delete
End With
'Get the duplicates on sheet 2 (if any) and the qty/row on the missing from sheet 2
With ws2
.Activate
.Rows(1).Insert
.Range("A1:D1").Value = Array("Item", "Qty", "Row", "Count")
End With
LRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
With ws2.Range("C2:C" & LRow)
.Value = Evaluate("Row(" & .Address(, , , 1) & ")")
End With
With ws2.Range("D2:D" & LRow)
.Value = Evaluate("Countif(A2:A" & LRow & "," & .Offset(, -3).Address(, , , 1) & ")")
End With
With ws2.Range("A1").CurrentRegion
.AutoFilter 4, ">1"
If .SpecialCells(xlCellTypeVisible).Address <> .Rows(1).Address Then
.Offset(1).Resize(, 3).Copy ws3.Range("H3")
End If
.AutoFilter
LRow = Application.Max(ws2.Cells(Rows.Count, "A").End(xlUp).Row, 2)
d = ws2.Range("A2:D" & LRow)
x = ws3.Range("A3:C" & ws3.Cells(Rows.Count, "A").End(xlUp).Row)
For i = 1 To UBound(x, 1)
For j = LBound(d, 1) To UBound(d, 1)
If d(j, 1) = x(i, 1) Then x(i, 2) = d(j, 2): x(i, 3) = d(j, 3)
Next j
Next i
ws3.Range("A3").Resize(UBound(x, 1), 3).Value = x
.Range("C:D").ClearContents
.Rows(1).Delete
End With
Application.Goto ws3.Cells(1), 1
Application.ScreenUpdating = True
End SubNote: You can erase these lines if the expected result sheet is empty before running the code.
Code:
LRow = Application.Max(ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row, 3)
ws3.Range("A3:Z" & LRow).ClearContentsI want every occurrence of the duplicated item with row number, date, quantity.
If this code provide the result like that.
I apologize I am not following you. The code provides the duplicate items with the row number, date, and quantity for both sheets.
Here is an image of the duplicate items of Sheet1.
If you have additional requirements, please share a demo file with your expected results in it. Thank you for your feedback!
The Code which you provide showing some error. I copied and paste it on file. But showing errors. It is not working. Also please tell me it shows all duplicate items as you mentioned on the previous answer regarding Hercules Sparx 2.0 RF 24" Black . Please can you provide file with code. a excel file with new code .
Last edited:
Hello John,
The code returns an error because of these lines:
Code:
LRow = Application.Max(ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row, 3)
ws3.Range("A3:Z" & LRow).ClearContentsThe code thinks you have existing data in the Expected Result sheet. So, it erases them first and then displays the output. I am guessing the sheet is empty in your case, hence the error. Just delete these lines if you do not want to encounter the error.
Thank you.
Last edited: