VBA Compare 2 lists and isolate 2 types of differences

JamesonMH

Board Regular
Hi folks,

I regularly have to compare 2 report lists (approx 10,000 rows on each report) that are nearly identical. However, there are always 3 types of differences (sorry my title says just 2 I couldn't edit it) throughout and I currently spend a lot of time finding/listing these differences. Below is a simple example. I'm still learning the VBA ropes and know the Dictionary would be handy (at least for the duplicates (reason #3 below), but after searching many old mrexcel posts, I'm just not sure where to start. My "desired result on a separate worksheet is noted below. Many thanks for any assistance. James

<b>Excel 2013/2016</b><table cellpadding="2.5px" rules="all" style=";background-color: rgb(255,255,255);border: 1px solid;border-collapse: collapse; border-color: rgb(187,187,187)"><colgroup><col width="25px" style="background-color: rgb(218,231,245)" /><col /><col /><col /><col /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: rgb(218,231,245);text-align: center;color: rgb(22,17,32)"><th></th><th>B</th><th>C</th><th>D</th><th>E</th><th>F</th><th>G</th><th>H</th><th>I</th><th>J</th></tr></thead><tbody><tr ><td style="color: rgb(22,17,32);text-align: center;">3</td><td style="font-weight: bold;;">List 1</td><td style="font-weight: bold;text-align: right;;"></td><td style="font-weight: bold;text-align: right;;"></td><td style="font-weight: bold;text-align: right;border-bottom: 1px solid black;;"></td><td style="font-weight: bold;text-align: right;;"></td><td style="font-weight: bold;;">List 2</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">4</td><td style="font-style: italic;text-decoration: underline;;">Last Name</td><td style="font-style: italic;text-decoration: underline;;">Bill Date</td><td style="border-right: 1px solid black;font-style: italic;text-decoration: underline;;">Bill Amt</td><td style="border-top: 1px solid black;border-right: 1px solid black;border-left: 1px solid black;font-style: italic;text-decoration: underline;;">Unique Identifier</td><td style="text-align: right;border-left: 1px solid black;font-style: italic;;"></td><td style="font-style: italic;text-decoration: underline;;">Last Name</td><td style="font-style: italic;text-decoration: underline;;">Bill Date</td><td style="border-right: 1px solid black;font-style: italic;text-decoration: underline;;">Bill Amt</td><td style="border-top: 1px solid black;border-right: 1px solid black;border-left: 1px solid black;font-style: italic;text-decoration: underline;;">Unique Identifier</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">5</td><td style=";">ABC</td><td style="text-align: right;;">Sunday, May 3, 2015</td><td style="text-align: right;border-right: 1px solid black;;">24.95</td><td style="border-right: 1px solid black;border-left: 1px solid black;;">R50821</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style=";">ABC</td><td style="text-align: right;;">Sunday, May 3, 2015</td><td style="text-align: right;border-right: 1px solid black;;">24.95</td><td style="border-right: 1px solid black;border-left: 1px solid black;;">R50821</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">6</td><td style=";">DEF</td><td style="text-align: right;;">Friday, August 12, 2016</td><td style="text-align: right;border-right: 1px solid black;background-color: #FFD966;;">23.58</td><td style="border-right: 1px solid black;border-left: 1px solid black;;">R50920</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style=";">DEF</td><td style="text-align: right;;">Friday, August 12, 2016</td><td style="text-align: right;border-right: 1px solid black;background-color: #FFD966;;">94.22</td><td style="border-right: 1px solid black;border-left: 1px solid black;;">R50920</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">7</td><td style="background-color: #FF0000;;">JKL</td><td style="text-align: right;background-color: #FF0000;;">Friday, December 12, 2014</td><td style="text-align: right;border-right: 1px solid black;background-color: #FF0000;;">14.25</td><td style="border-right: 1px solid black;border-left: 1px solid black;background-color: #FF0000;;">R50920</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style=";">MNO</td><td style="text-align: right;;">Tuesday, September 18, 2018</td><td style="text-align: right;border-right: 1px solid black;;">20.55</td><td style="border-right: 1px solid black;border-left: 1px solid black;;">AZ1025</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">8</td><td style=";">MNO</td><td style="text-align: right;;">Tuesday, September 18, 2018</td><td style="text-align: right;border-right: 1px solid black;;">20.55</td><td style="border-right: 1px solid black;border-left: 1px solid black;;">AZ1025</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="background-color: #00B0F0;;">ABC</td><td style="text-align: right;background-color: #00B0F0;;">Sunday, May 3, 2015</td><td style="text-align: right;border-right: 1px solid black;background-color: #00B0F0;;">24.95</td><td style="border-right: 1px solid black;border-left: 1px solid black;background-color: #00B0F0;;">R50821</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">9</td><td style="background-color: #00B0F0;;">ABC</td><td style="text-align: right;background-color: #00B0F0;;">Sunday, May 3, 2015</td><td style="text-align: right;border-right: 1px solid black;background-color: #00B0F0;;">24.95</td><td style="border-right: 1px solid black;border-left: 1px solid black;background-color: #00B0F0;;">R50821</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="background-color: #00B0F0;;">ABC</td><td style="text-align: right;background-color: #00B0F0;;">Sunday, May 3, 2015</td><td style="text-align: right;border-right: 1px solid black;background-color: #00B0F0;;">24.95</td><td style="border-right: 1px solid black;border-left: 1px solid black;background-color: #00B0F0;;">R50821</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">10</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;"></td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">11</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">12</td><td style="font-style: italic;;">3 Reasons for not reconciling:</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">13</td><td style="background-color: #FFD966;;">1. Billed amount <></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">14</td><td style="background-color: #FF0000;;">2. Transaction line only on 1 list (can be either list)</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">15</td><td style="background-color: #00B0F0;;">3. Duplicate on 1 or both lists</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">16</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">17</td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">18</td><td style="border-top: 1px solid black;border-left: 1px solid black;font-style: italic;;">Desired result (on a separate worksheet):</td><td style="font-weight: bold;text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">19</td><td style="text-align: right;border-left: 1px solid black;font-style: italic;;"></td><td style="font-weight: bold;text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">20</td><td style="border-left: 1px solid black;text-decoration: underline;;">List 1</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-decoration: underline;;">List 2</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">21</td><td style="font-weight: bold;border-left: 1px solid black;;">Billed amount not equal</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="font-weight: bold;;">Billed amount not equal</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">22</td><td style="border-left: 1px solid black;;">DEF</td><td style=";">Friday, August 12, 2016</td><td style="text-align: right;;">23.58</td><td style=";">R50920</td><td style="text-align: right;;"></td><td style=";">DEF</td><td style=";">Friday, August 12, 2016</td><td style="text-align: right;;">94.22</td><td style="border-right: 1px solid black;;">R50920</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">23</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">24</td><td style="font-weight: bold;border-left: 1px solid black;;">Transaction line only on 1 list (can be either list)</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";"></td><td style="text-align: right;;"></td><td style="font-weight: bold;;">Transaction line only on 1 list (can be either list)</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">25</td><td style="border-left: 1px solid black;;">JKL</td><td style=";">Friday, December 12, 2014</td><td style="text-align: right;;">14.25</td><td style=";">R50920</td><td style="text-align: right;;"></td><td style=";">None</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">26</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">27</td><td style="font-weight: bold;border-left: 1px solid black;;">Duplicate on 1 or both lists</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";"></td><td style="text-align: right;;"></td><td style="font-weight: bold;;">Duplicate on 1 or both lists</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">28</td><td style="border-left: 1px solid black;;">ABC</td><td style=";">Sunday, May 3, 2015</td><td style="text-align: right;;">24.95</td><td style=";">R50821</td><td style="text-align: right;;"></td><td style=";">ABC</td><td style=";">Sunday, May 3, 2015</td><td style="text-align: right;;">24.95</td><td style="border-right: 1px solid black;;">R50821</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">29</td><td style="text-align: right;border-bottom: 1px solid black;border-left: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="border-bottom: 1px solid black;;"></td><td style="text-align: right;border-bottom: 1px solid black;;"></td><td style="border-bottom: 1px solid black;;">ABC</td><td style="border-bottom: 1px solid black;;">Sunday, May 3, 2015</td><td style="text-align: right;border-bottom: 1px solid black;;">24.95</td><td style="border-right: 1px solid black;border-bottom: 1px solid black;;">R50821</td></tr></tbody></table><p style="width:4.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid rgb(187,187,187);border-top:none;text-align: center;background-color: rgb(218,231,245);color: rgb(22,17,32)">Sheet1</p><br /><br />

 
Last edited:

pbornemeier

Well-known Member
This is a start to what you asked for.
Some questions have to be resolved before it is complete.
Note that there was some inconsistencies in the sample data and the sample desired results
-- ABC occurring 2 times in List 1 and 3 in List 2 vice 1/2
-- Unique ID R50920 showing up twice


Is the Unique ID for a transaction or the user?
If there is a chance of the unique ID being duplicated, then there may be a problem with the software providing your data.

You may want to include the source list row number in your results to make finding the problem rows easier


What should happen if billed amounts are not equal among the 2 otherwise matching items on List 1 and 3 items on List 2?



Code:
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
 

JamesonMH

Board Regular
Wow, that's some serious code, thanks Phil - I appreciate it and will work through it all this evening! I had given up on getting a reply and have been working on my own solution since, but this looks much stronger.

To answer, the unique ID represents the transaction (but we create this ID in Excel using CONCAT from 2 report fields once we dump the lists from the software into Excel). Sometimes (albeit rarely) the same transaction goes through the system twice in error so I need to catch it (i.e. the blue highlights). To your point, we can simplify and ditch the 2 blue ABC's at the bottom of List 2. I'd still need the blue duplicate ABC at bottom of List 1 called out though.

As a background, it's 2 separate reports from the software I'm comparing and the 3 types of differences need to be ID'd so a separate person can dig into them and reconcile.

To your last question...if the billing amount doesn't match but everything else does, then they both s/b shown as reconciling items under "Billed amount not equal". Then any further occurrences (since they're sorted in ascending date order) s/b called out as duplicates.

Please let me know if I missed anything.

James
 

pbornemeier

Well-known Member
This is a simpler version.

The output is combined to display only rows where the is not one of each Unique Identifier in each list and/or the amounts are different. In addition it also displays the rows that contain the problem data so that they can more easily found.

Code:
Option Explicit

Sub OnePassCompare()

    Dim oSD As Object
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long, lWrite As Long
    Dim sItem As String
    
    Dim rngList1 As Range                   '4 columns, Last Name/Bill Date/Bill Amt/UID
    Dim rngList2 As Range                   '4 columns, Last Name/Bill Date/Bill Amt/UID
    Dim sOutputSheetName As String
    Const bShowAll As Boolean = False       'True to show all rows, False to show only errors
    Dim bBad As Boolean
    
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    'Data stored in SD Item as an Array(0 to 4)
    '  0  List1Count(#)
    '  1  List2Count(#)
    '  2  List1Rows (String)
    '  3  List2Rows (String)
    '  4  Add1/Sub2 (#)
    'If everything is OK each UID should have an
    'List1Count = 1, List2Count = 1, Add1/Sub2 = 0
    
    '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 Each rngCell In rngList1.Columns(4).Cells
        sItem = rngCell.Value
        If IsEmpty(oSD.Item(sItem)) Then
            'Populate item array columns 0,2,4 with list 1 values
            'Populate item 1 (List 2 count) with 0
            'Populate item 3 (List 2 row) with a blank
            oSD.Item(sItem) = Array(1, _
                0, _
                rngCell.Row, _
                "", _
                rngCell.Offset(0, -1).Value)
        Else
            'Update item array columns 0,2,4
            'Copy existing List 2 items (1,3)
            oSD.Item(sItem) = Array(oSD.Item(sItem)(0) + 1, _
                0, _
                oSD.Item(sItem)(2) & "  " & rngCell.Row, _
                "", _
                oSD.Item(sItem)(4) + rngCell.Offset(0, -1).Value)
        End If
    Next
    
    For Each rngCell In rngList2.Columns(4).Cells
        sItem = rngCell.Value
        If IsEmpty(oSD.Item(sItem)) Then
            'Populate item array columns 1,3,4 with list 2 values
            'Populate item 0 (List 1 count) with 0
            'Populate item 2 (List 1 row) with a blank
            oSD.Item(sItem) = Array(0, _
                1, _
                "", _
                rngCell.Row, _
                -rngCell.Offset(0, -1).Value)
        Else
            'Update item array columns 1,3,4
            'Copy existing List 1 items (0,2)
            oSD.Item(sItem) = Array(oSD.Item(sItem)(0), _
                oSD.Item(sItem)(1) + 1, _
                oSD.Item(sItem)(2), _
                oSD.Item(sItem)(3) & "  " & rngCell.Row, _
                oSD.Item(sItem)(4) - rngCell.Offset(0, -1).Value)
        End If
    Next
    
    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
        
        If bShowAll Then
            'Show All - for test and validation
            With Worksheets(sOutputSheetName)
                Range("A1").Resize(1, 6).Value = Array("UID", "List 1 Count", _
                    "List 2 Count", "List 1 Rows", "List 2 Rows", _
                    "+ List 1 Values - List 2 Values")
    
                For lIndex = 1 To oSD.Count             'Count = n+1
                    varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
                    .Cells(lIndex + 1, 1).Resize(1, 6).Value = _
                        Array(varTemp(1, lIndex), varTemp(2, lIndex)(0), _
                        varTemp(2, lIndex)(1), varTemp(2, lIndex)(2), _
                        varTemp(2, lIndex)(3), varTemp(2, lIndex)(4))
                Next
    
                .UsedRange.Columns.AutoFit
            End With
        
        Else
        'Show Only Errors
            With Worksheets(sOutputSheetName)
                Range("A1").Resize(1, 6).Value = Array("UID", "List 1 Count", _
                    "List 2 Count", "List 1 Rows", "List 2 Rows", _
                    "+ List 1 Values - List 2 Values")
                For lIndex = 1 To oSD.Count             'Count = n+1
                    bBad = False
                    varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
                    If varTemp(2, lIndex)(0) <> 1 Then bBad = True 'Count of UID in List 1 <> 1
                    If varTemp(2, lIndex)(1) <> 1 Then bBad = True 'Count of UID in List 2 <> 1
                    If varTemp(2, lIndex)(4) <> 0 Then bBad = True 'Amounts are not equal
                    If bBad Then
                        lWrite = lWrite + 1
                        .Cells(lWrite + 1, 1).Resize(1, 6).Value = _
                            Array(varTemp(1, lIndex), varTemp(2, lIndex)(0), _
                            varTemp(2, lIndex)(1), varTemp(2, lIndex)(2), _
                            varTemp(2, lIndex)(3), varTemp(2, lIndex)(4))
                    End If
                Next
                
                .UsedRange.Columns.AutoFit
            End With
        End If
        
    End If

End Sub
 

JamesonMH

Board Regular
This is a simpler version.

The output is combined to display only rows where the is not one of each Unique Identifier in each list and/or the amounts are different. In addition it also displays the rows that contain the problem data so that they can more easily found.

Code:
Option Explicit

Sub OnePassCompare()

    Dim oSD As Object
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long, lWrite As Long
    Dim sItem As String
    
    Dim rngList1 As Range                   '4 columns, Last Name/Bill Date/Bill Amt/UID
    Dim rngList2 As Range                   '4 columns, Last Name/Bill Date/Bill Amt/UID
    Dim sOutputSheetName As String
    Const bShowAll As Boolean = False       'True to show all rows, False to show only errors
    Dim bBad As Boolean
    
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    'Data stored in SD Item as an Array(0 to 4)
    '  0  List1Count(#)
    '  1  List2Count(#)
    '  2  List1Rows (String)
    '  3  List2Rows (String)
    '  4  Add1/Sub2 (#)
    'If everything is OK each UID should have an
    'List1Count = 1, List2Count = 1, Add1/Sub2 = 0
    
    '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 Each rngCell In rngList1.Columns(4).Cells
        sItem = rngCell.Value
        If IsEmpty(oSD.Item(sItem)) Then
            'Populate item array columns 0,2,4 with list 1 values
            'Populate item 1 (List 2 count) with 0
            'Populate item 3 (List 2 row) with a blank
            oSD.Item(sItem) = Array(1, _
                0, _
                rngCell.Row, _
                "", _
                rngCell.Offset(0, -1).Value)
        Else
            'Update item array columns 0,2,4
            'Copy existing List 2 items (1,3)
            oSD.Item(sItem) = Array(oSD.Item(sItem)(0) + 1, _
                0, _
                oSD.Item(sItem)(2) & "  " & rngCell.Row, _
                "", _
                oSD.Item(sItem)(4) + rngCell.Offset(0, -1).Value)
        End If
    Next
    
    For Each rngCell In rngList2.Columns(4).Cells
        sItem = rngCell.Value
        If IsEmpty(oSD.Item(sItem)) Then
            'Populate item array columns 1,3,4 with list 2 values
            'Populate item 0 (List 1 count) with 0
            'Populate item 2 (List 1 row) with a blank
            oSD.Item(sItem) = Array(0, _
                1, _
                "", _
                rngCell.Row, _
                -rngCell.Offset(0, -1).Value)
        Else
            'Update item array columns 1,3,4
            'Copy existing List 1 items (0,2)
            oSD.Item(sItem) = Array(oSD.Item(sItem)(0), _
                oSD.Item(sItem)(1) + 1, _
                oSD.Item(sItem)(2), _
                oSD.Item(sItem)(3) & "  " & rngCell.Row, _
                oSD.Item(sItem)(4) - rngCell.Offset(0, -1).Value)
        End If
    Next
    
    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
        
        If bShowAll Then
            'Show All - for test and validation
            With Worksheets(sOutputSheetName)
                Range("A1").Resize(1, 6).Value = Array("UID", "List 1 Count", _
                    "List 2 Count", "List 1 Rows", "List 2 Rows", _
                    "+ List 1 Values - List 2 Values")
    
                For lIndex = 1 To oSD.Count             'Count = n+1
                    varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
                    .Cells(lIndex + 1, 1).Resize(1, 6).Value = _
                        Array(varTemp(1, lIndex), varTemp(2, lIndex)(0), _
                        varTemp(2, lIndex)(1), varTemp(2, lIndex)(2), _
                        varTemp(2, lIndex)(3), varTemp(2, lIndex)(4))
                Next
    
                .UsedRange.Columns.AutoFit
            End With
        
        Else
        'Show Only Errors
            With Worksheets(sOutputSheetName)
                Range("A1").Resize(1, 6).Value = Array("UID", "List 1 Count", _
                    "List 2 Count", "List 1 Rows", "List 2 Rows", _
                    "+ List 1 Values - List 2 Values")
                For lIndex = 1 To oSD.Count             'Count = n+1
                    bBad = False
                    varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
                    If varTemp(2, lIndex)(0) <> 1 Then bBad = True 'Count of UID in List 1 <> 1
                    If varTemp(2, lIndex)(1) <> 1 Then bBad = True 'Count of UID in List 2 <> 1
                    If varTemp(2, lIndex)(4) <> 0 Then bBad = True 'Amounts are not equal
                    If bBad Then
                        lWrite = lWrite + 1
                        .Cells(lWrite + 1, 1).Resize(1, 6).Value = _
                            Array(varTemp(1, lIndex), varTemp(2, lIndex)(0), _
                            varTemp(2, lIndex)(1), varTemp(2, lIndex)(2), _
                            varTemp(2, lIndex)(3), varTemp(2, lIndex)(4))
                    End If
                Next
                
                .UsedRange.Columns.AutoFit
            End With
        End If
        
    End If

End Sub
Your revised code seems to be working quite well so far.

You've been a really great help - thanks again for everything Phil! :)

James
 

Some videos you may like

This Week's Hot Topics

  • Get External Data (long shot question!)
    This is likely a long shot but I am wondering if it is at all possible for Excel to somehow 'change' the contents of a URL that is being linked to...
  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • Cell Formatting
    Good Morning, I need to format a few different cells in the following manners: A1 has to always add a colon (:) after whatever is typed in by a...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • Workbook_Change stopped working !
    I am working on an app to speed up & automate processing of Credit Cards statements. After data is input from a CSV file, it is presented to the...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
Top