Comparison for Reconciliation

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

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

Attachment 20345

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.

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

Please see attachmentAttachment 20348

Bump...

Code:

---

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

---

Wow, bless you and bless Scotland.

Worked like a charm!

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

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("A1:D4")


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

Code:

---

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

---

Very Informative. Thanks Again :)