Option Explicit
Sub CompareLists()
'https://www.mrexcel.com/forum/excel-questions/1112192-vba-compare-2-lists-isolate-2-types-differences.html
Dim rngList1 As Range '4 columns, Last Name/Bill Date/Bill Amt/UID
Dim rngList2 As Range
Dim rngListA As Range
Dim rngListB As Range
Dim sOutputSheetName As String
Dim lCheckIndex As Long
Dim lWriteRow As Long
Dim sItem As String
Dim lDupe As Long
Dim oFound As Object
Dim oSD As Object
Dim rngCell As Range
Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long, lWrite As Long
'Update to suit your needs ========================================================
'There are ways to automate the defining of the ranges, depending on your setup
Set rngList1 = Worksheets("Sheet2").Range("A3:D8") '4-Column data range for list 1
Set rngList2 = Worksheets("Sheet2").Range("F3:I7") '4-Column data range for list 2
sOutputSheetName = "Output" 'Output sheet name
'==================================================================================
'Recreate Output Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(sOutputSheetName).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sOutputSheetName 'After last
For lCheckIndex = 1 To 2
'Setup
lWriteRow = lWriteRow + 2
If lCheckIndex = 1 Then
Set rngListA = rngList1
Set rngListB = rngList2
Worksheets(sOutputSheetName).Cells(lWriteRow, 1).Value = "List 1"
Else
Set rngListA = rngList2
Set rngListB = rngList1
Worksheets(sOutputSheetName).Cells(lWriteRow, 1).Value = "List 2"
End If
'Billed amount not equal (assumes other 3 columns match)
'Also assumes a single match in each list
'If this is not the case these problems will be shown by toher checks
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
'Add amount(s) for matching cells in List A
For Each rngCell In rngListA.Columns(1).Cells
sItem = rngCell.Value & vbTab & rngCell.Offset(0, 1).Value & _
vbTab & rngCell.Offset(0, 3).Value
'Keys will contain the Name, Date, ID, Items will contain the amount
'Normal method of incrementing the key's item by 1
oSD.Item(sItem) = oSD.Item(sItem) + rngCell.Offset(0, 2).Value
Next
'Remove amount(s) for matching cells from List B
For Each rngCell In rngListB.Columns(1).Cells
sItem = rngCell.Value & vbTab & rngCell.Offset(0, 1).Value & _
vbTab & rngCell.Offset(0, 3).Value
If oSD.exists(sItem) Then
oSD.Item(sItem) = oSD.Item(sItem) - rngCell.Offset(0, 2).Value
End If
Next
If oSD.Count > 0 Then
lWrite = 0
'There should be many items here
ReDim varTemp(1 To 2, 1 To oSD.Count)
varK = oSD.keys: varI = oSD.Items
For lIndex = 1 To oSD.Count
'Only include those that do npt have a index of 0
If varI(lIndex - 1) <> 0 Then
lWrite = lWrite + 1
varTemp(1, lWrite) = varK(lIndex - 1): varTemp(2, lWrite) = varI(lIndex - 1)
End If
Next
ReDim Preserve varTemp(1 To 2, 1 To lWrite)
lWriteRow = lWriteRow + 2
Worksheets(sOutputSheetName).Cells(lWriteRow, 1).Value = "Billed Amount <>"
For lIndex = 1 To lWrite
sItem = Split(varTemp(1, lIndex), vbTab)(2) 'UID
Set oFound = rngListA.Columns(4).Find(What:=sItem, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
lWriteRow = lWriteRow + 1
Range(oFound.Offset(0, -3), oFound).Copy Destination:= _
Worksheets(sOutputSheetName).Cells(lWriteRow, 1)
Next
End If
'============================================================================
'Find unmatched UID
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
'Count how often UIDs appear
For Each rngCell In rngListA.Columns(4).Cells
'Keys will contain the UID, Items will contain the count of each UID
'Normal method of incrementing the key's item by 1
oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
Next
'Remove Matching cells from List B
For Each rngCell In rngListB.Columns(4).Cells
If oSD.exists(rngCell.Value) Then
oSD.Remove rngCell.Value
End If
Next
'Check for mismatch - UID in one list but not another
'If multiple UID in one list then all will be shown
If oSD.Count > 0 Then
'Some UID in A that were not in B
ReDim varTemp(1 To 2, 1 To oSD.Count)
varK = oSD.keys: varI = oSD.Items
For lIndex = 1 To oSD.Count
varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
Next
lWriteRow = lWriteRow + 2
Worksheets(sOutputSheetName).Cells(lWriteRow, 1).Value = "Transaction line only on 1 list"
'Find matching row from list and copy to output
For lIndex = 1 To oSD.Count
sItem = varTemp(1, lIndex)
For lDupe = 1 To varTemp(2, lIndex)
If lDupe > 1 Then
Set oFound = rngListA.Find(What:=sItem, After:=oFound, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Else
Set oFound = rngListA.Columns(4).Find(What:=sItem, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End If
lWriteRow = lWriteRow + 1
If Not oFound Is Nothing Then
'copy row to output
Range(oFound, oFound.Offset(0, -3)).Copy Destination:= _
Worksheets(sOutputSheetName).Cells(lWriteRow, 1)
Else
'copy UID to output
oFound.Copy Destination:= _
Worksheets(sOutputSheetName).Cells(lWriteRow, 4)
End If
Next
Next
End If
'============================================================================
'Find Exact (All 4 columns match) Duplicates in List A (Count stored as #-0 in SD Items
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
'Concatenate all 4 columns & Count how often that appears
For Each rngCell In rngListA.Columns(1).Cells
sItem = rngCell.Value & vbTab & rngCell.Offset(0, 1).Value & _
vbTab & rngCell.Offset(0, 2).Value & vbTab & rngCell.Offset(0, 3).Value
'Keys will contain the Concatenated Cells, Items will contain the complex count of each UID
'Normal method of incrementing the key's item by 1
'oSD.Item(sItem) = oSD.Item(sItem) + 1
'More complex method to handle totals for 2 lists
If oSD.Item(sItem) = vbNullString Then
oSD.Item(sItem) = 1 & "-0"
Else
oSD.Item(sItem) = Split(oSD.Item(sItem), "-")(0) + 1 & "-0"
End If
Next
'Find Duplicates in B (Count stored as A-# in SD Items
For Each rngCell In rngListB.Columns(1).Cells
sItem = rngCell.Value & vbTab & rngCell.Offset(0, 1).Value & _
vbTab & rngCell.Offset(0, 2).Value & vbTab & rngCell.Offset(0, 3).Value
Debug.Print sItem
'Keys will contain the Concatenated Cells, Items will contain the complex count of each UID
'oSD.Item(sItem) = oSD.Item(sItem) + 1
If oSD.Item(sItem) = vbNullString Then
oSD.Item(sItem) = "0-1"
Else
If Len(Split(oSD.Item(sItem), "-")(1)) = 0 Then
oSD.Item(sItem) = Split(oSD.Item(sItem), "-")(0) & _
"-" & Split(oSD.Item(sItem), "-")(1) & 1
Else
oSD.Item(sItem) = Split(oSD.Item(sItem), "-")(0) & _
"-" & Split(oSD.Item(sItem), "-")(1) + 1
End If
End If
Next
'Write to manipulable array
If oSD.Count > 0 Then
lWrite = 0
ReDim varTemp(1 To 2, 1 To oSD.Count)
varK = oSD.keys: varI = oSD.Items 'Both are (0 to n) arrays
For lIndex = 1 To oSD.Count 'Count = n+1
If Split(varI(lIndex - 1), "-")(0) > 1 Or Split(varI(lIndex - 1), "-")(1) > 1 Then
'Write UIDs with either value in the item > 1
lWrite = lWrite + 1
varTemp(1, lWrite) = varK(lIndex - 1): varTemp(2, lWrite) = varI(lIndex - 1)
End If
Next
If lWrite > 0 Then
ReDim Preserve varTemp(1 To 2, 1 To lWrite)
'There were some duplicates
lWriteRow = lWriteRow + 2
Worksheets(sOutputSheetName).Cells(lWriteRow, 1).Value = "(Exact) Duplicate on 1 or both lists"
For lIndex = 1 To lWrite
If Split(varTemp(2, lIndex), "-")(0) > 1 Then
For lDupe = 1 To Split(varTemp(2, lIndex), "-")(0)
lWriteRow = lWriteRow + 1
Worksheets(sOutputSheetName).Cells(lWriteRow, 1).Resize(1, 4).Value = Split(varTemp(1, lIndex), vbTab)
Next
End If
Next
End If
End If
Next lCheckIndex
End Sub
