Comparison for Reconciliation

[Sandler]

Dear Friends,

I have information in columns A:C that I need to compare to columns F:G.

Column A is a Position (Text), Column B is a number, Column C is a Name (text).
Column F is a Position (Text), Column G is a number, Column H is a Name (text).

I need the script to look at the first set of info (starts in row 3, will be A3:C3).
If a match is found in a specific row in Columns F:H, I need it to delete both piece of info.
For example if in A3:C3, an exact match is found in F10:H10, then I need those 2 ranges to be deleted.

If a match is not found then, I need it to go to the next set of information.

Thanks in advance

[mdmackillop]

Can you mock up a file and post it to save responders each making their own?

[Sandler]

Comparison Example.jpg

Thanks mdmackillop. The top part of the picture is the original information. The bottom is what the results would be. In the bottom part I also sorted Columns A:C by Column A and Columns F:H, by Column F. This is just to bring the information upwards.

Thanks.

[mdmackillop]

Can you post a file, not a picture. Go Advanced / Manage Attachments

[Sandler]

Please see attachmentComparison File.xlsx

[Sandler]

Bump...

[mdmackillop]

Sub Test() 
   Dim LRw As Long
    Dim arr()
    Dim dic1, dic2
    
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    
    LRw1 = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 3 To LRw1
        dic1.Add i, Cells(i, 1) & "#" & Cells(i, 2) & "#" & Cells(i, 3)
    Next i
    LRw2 = Cells(Rows.Count, 6).End(xlUp).Row
    For i = 3 To LRw2
        dic2.Add i, Cells(i, 6) & "#" & Cells(i, 7) & "#" & Cells(i, 8)
    Next i
    
    For i = LRw1 To 3 Step -1
        dup = False
        For Each kk In dic2.keys
            If dic1(i) = dic2(kk) Then
                Cells(kk, 6).Resize(, 3).ClearContents
                dup = True
            End If
        Next kk
        If dup Then Cells(i, 1).Resize(, 3).Delete shift:=xlUp
    Next i
    For i = LRw2 To 3 Step -1
        If Cells(i, 6) = "" Then Cells(i, 6).Resize(, 3).Delete shift:=xlUp
    Next i
End Sub

[Sandler]

Wow, bless you and bless Scotland.

Worked like a charm!

[Sandler]

Can I ask someone to put detailed comments in the vba code above? It works great and I would really like to understand how it works. I understand the LRw1 = Cells(Rows.Count, 1).End(xlUp).Row is looking at the first set of information and LRw2 = Cells(Rows.Count, 6).End(xlUp).Row is looking at the second set. I am unfamiliar with the scripting dictionary and the reason behind the hast tags when we add dic1 or dic2. I never really understood the resize.

Thanks in advance

[mdmackillop]

For Dictionaries, have a read of this

Resize expands a range to a different area. In this case, from 1 cell to 3 cells horizontally.
Instead of Cells(i, 1).Resize(, 3) I might have used Range(Cells(i,1), Cells(i,3))

Range("A1").Resize(4,4) => Range("A14")


The # is used as a separator when joining cells to avoid accidental duplicates
eg join 123, 456, 789 =>123456789 : with separator 123#456#789
join 12, 345, 6789 =>123459789 : with separator 12#345#6789

Sub Test()    Dim LRw As Long
    Dim arr()
    Dim dic1, dic2
     
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
     
    LRw1 = Cells(Rows.Count, 1).End(xlUp).Row
    'Add row number as key and concatenated cells as value; Area1
    For i = 3 To LRw1
        dic1.Add i, Cells(i, 1) & "#" & Cells(i, 2) & "#" & Cells(i, 3)
    Next i
    LRw2 = Cells(Rows.Count, 6).End(xlUp).Row
    'Add row number as key and concatenated cells as value; Area2
    For i = 3 To LRw2
        dic2.Add i, Cells(i, 6) & "#" & Cells(i, 7) & "#" & Cells(i, 8)
    Next i
     
    'Loop through keys from last to first in Area1
    For i = LRw1 To 3 Step -1
        dup = False
        For Each kk In dic2.keys
            If dic1(i) = dic2(kk) Then
                ' If Dup found, clear Area2 cells
                Cells(kk, 6).Resize(, 3).ClearContents
                'Set flag value
                dup = True
            End If
        Next kk
        'If dup found, delete row from Area1
        If dup Then Cells(i, 1).Resize(, 3).Delete shift:=xlUp
    Next i
    'Loop through Area2 from bottom and delete blank cells
    For i = LRw2 To 3 Step -1
        If Cells(i, 6) = "" Then Cells(i, 6).Resize(, 3).Delete shift:=xlUp
    Next i
End Sub

[Sandler]

Very Informative. Thanks Again