Comparing 2 datasets for reconciliation using VBA

BigMo1987

New Member
Joined
Jan 11, 2021
Messages
21
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
Hello all,

I am looking for a VBA code to reconcile two data sets in Sheet1 and Sheet2 (See attached report). Looking for qty differences between both sheets and identifying if a column A, B or C and have any discrepancies. Can anyone help?
1610419126028.png

Thank you in advance!
 
Something like this?

VBA Code:
Sub Compare_Difference()

Dim eRow1&, eRow2&
Dim cell1 As Range, cell2 As Range
Dim rngSht1 As Range, rngSht2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

' Get last row for each data on Sheet1 and Sheet2
eRow1 = ws1.Range("A1").End(xlDown).Row
eRow2 = ws2.Range("A1").End(xlDown).Row

' Define Range for each sheet
Set rngSht1 = ws1.Range("A2", "A" & eRow1)
Set rngSht2 = ws2.Range("A2", "A" & eRow2)

ws1.Range("D1") = "Diff (Sht2 - Sht1)"
For Each cell1 In rngSht1
    For Each cell2 In rngSht2
        If cell2 = cell1 And cell2.Offset(0, 1) = cell1.Offset(0, 1) Then
            Select Case True
                Case ws2.Range("C" & cell2.Row) = ws1.Range("C" & cell1.Row)
                    ws2.Range("A" & cell2.Row, "C" & cell2.Row).Interior.ColorIndex = 6
                Case Else
                    ws2.Range("A" & cell2.Row, "B" & cell2.Row).Interior.ColorIndex = 6
                    ws1.Range("D" & cell1.Row) = ws2.Range("C" & cell2.Row) - ws1.Range("C" & cell1.Row)
            End Select
        End If
    Next
Next

ws2.Range("D1") = "Diff (Sht1 - Sht2)"
For Each cell2 In rngSht2
    For Each cell1 In rngSht1
        If cell1 = cell2 And cell1.Offset(0, 1) = cell2.Offset(0, 1) Then
            Select Case True
                Case ws1.Range("C" & cell1.Row) = ws2.Range("C" & cell2.Row)
                    ws1.Range("A" & cell1.Row, "C" & cell1.Row).Interior.ColorIndex = 42
                Case Else
                    ws1.Range("A" & cell1.Row, "B" & cell1.Row).Interior.ColorIndex = 42
                    ws2.Range("D" & cell2.Row) = ws1.Range("C" & cell1.Row) - ws2.Range("C" & cell2.Row)
            End Select
        End If
    Next
Next
   
Application.ScreenUpdating = True
It works. Thank you so much for your help!
 
Upvote 0

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
I wrote the difference in Sheet1 column D and highlight Yellow matching columns (A,B,C or just A,B if C is different)

VBA Code:
Sub Compare_Difference()

Dim eRow1&, eRow2&
Dim cell1 As Range, cell2 As Range
Dim rngSht1 As Range, rngSht2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

' Get last row for each data on Sheet1 and Sheet2
eRow1 = ws1.Range("A1").End(xlDown).Row
eRow2 = ws2.Range("A1").End(xlDown).Row

' Define Range for each sheet
Set rngSht1 = ws1.Range("A2", "A" & eRow1)
Set rngSht2 = ws2.Range("A2", "A" & eRow2)

For Each cell1 In rngSht1
    For Each cell2 In rngSht2
        If cell2 = cell1 And cell2.Offset(0, 1) = cell1.Offset(0, 1) Then
            Select Case True
                Case ws2.Range("C" & cell2.Row) = ws1.Range("C" & cell1.Row)
                    ws2.Range("A" & cell2.Row, "C" & cell2.Row).Interior.ColorIndex = 6
                Case Else
                    ws2.Range("A" & cell2.Row, "B" & cell2.Row).Interior.ColorIndex = 6
                    ws1.Range("D" & cell1.Row) = ws2.Range("C" & cell2.Row) - ws1.Range("C" & cell1.Row)
            End Select
        End If
    Next
Next
   
Application.ScreenUpdating = True

End Sub
Hello Zot, Can you please add a statement to sort both column A in sheet 1 and 2 from smallest to largest while doing the comparison ?
 
Upvote 0
VBA Code:
Sub Compare_Difference()

Dim eRow1&, eRow2&
Dim cell1 As Range, cell2 As Range
Dim rngSht1 As Range, rngSht2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

' Get last row for each data on Sheet1 and Sheet2
eRow1 = ws1.Range("A1").End(xlDown).Row
eRow2 = ws2.Range("A1").End(xlDown).Row

' Define Range for each sheet
Set rngSht1 = ws1.Range("A2", "A" & eRow1)
Set rngSht2 = ws2.Range("A2", "A" & eRow2)

' Compare list in ws1 to ws2
ws1.Range("D1") = "Diff (Sht2 - Sht1)"
For Each cell1 In rngSht1
    For Each cell2 In rngSht2
        If cell2 = cell1 And cell2.Offset(0, 1) = cell1.Offset(0, 1) Then
            Select Case True
                Case ws2.Range("C" & cell2.Row) = ws1.Range("C" & cell1.Row)
                    ws2.Range("A" & cell2.Row, "C" & cell2.Row).Interior.ColorIndex = 6
                Case Else
                    ws2.Range("A" & cell2.Row, "B" & cell2.Row).Interior.ColorIndex = 6
                    ws1.Range("D" & cell1.Row) = ws2.Range("C" & cell2.Row) - ws1.Range("C" & cell1.Row)
            End Select
        End If
    Next
Next

' Compare list in ws2 to ws1
ws2.Range("D1") = "Diff (Sht1 - Sht2)"
For Each cell2 In rngSht2
    For Each cell1 In rngSht1
        If cell1 = cell2 And cell1.Offset(0, 1) = cell2.Offset(0, 1) Then
            Select Case True
                Case ws1.Range("C" & cell1.Row) = ws2.Range("C" & cell2.Row)
                    ws1.Range("A" & cell1.Row, "C" & cell1.Row).Interior.ColorIndex = 42
                Case Else
                    ws1.Range("A" & cell1.Row, "B" & cell1.Row).Interior.ColorIndex = 42
                    ws2.Range("D" & cell2.Row) = ws1.Range("C" & cell1.Row) - ws2.Range("C" & cell2.Row)
            End Select
        End If
    Next
Next

' Sort ws1
With ws1.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow1)
    .Header = xlYes
    .Apply
End With
    
' Sort ws2
With ws2.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow2)
    .Header = xlYes
    .Apply
End With

' Return cursor to cell A1 for each worksheet
Application.Goto ws2.Range("A1"), True
Application.Goto ws1.Range("A1"), True
        
Application.ScreenUpdating = True

End Sub
 
Upvote 0
VBA Code:
Sub Compare_Difference()

Dim eRow1&, eRow2&
Dim cell1 As Range, cell2 As Range
Dim rngSht1 As Range, rngSht2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

' Get last row for each data on Sheet1 and Sheet2
eRow1 = ws1.Range("A1").End(xlDown).Row
eRow2 = ws2.Range("A1").End(xlDown).Row

' Define Range for each sheet
Set rngSht1 = ws1.Range("A2", "A" & eRow1)
Set rngSht2 = ws2.Range("A2", "A" & eRow2)

' Compare list in ws1 to ws2
ws1.Range("D1") = "Diff (Sht2 - Sht1)"
For Each cell1 In rngSht1
    For Each cell2 In rngSht2
        If cell2 = cell1 And cell2.Offset(0, 1) = cell1.Offset(0, 1) Then
            Select Case True
                Case ws2.Range("C" & cell2.Row) = ws1.Range("C" & cell1.Row)
                    ws2.Range("A" & cell2.Row, "C" & cell2.Row).Interior.ColorIndex = 6
                Case Else
                    ws2.Range("A" & cell2.Row, "B" & cell2.Row).Interior.ColorIndex = 6
                    ws1.Range("D" & cell1.Row) = ws2.Range("C" & cell2.Row) - ws1.Range("C" & cell1.Row)
            End Select
        End If
    Next
Next

' Compare list in ws2 to ws1
ws2.Range("D1") = "Diff (Sht1 - Sht2)"
For Each cell2 In rngSht2
    For Each cell1 In rngSht1
        If cell1 = cell2 And cell1.Offset(0, 1) = cell2.Offset(0, 1) Then
            Select Case True
                Case ws1.Range("C" & cell1.Row) = ws2.Range("C" & cell2.Row)
                    ws1.Range("A" & cell1.Row, "C" & cell1.Row).Interior.ColorIndex = 42
                Case Else
                    ws1.Range("A" & cell1.Row, "B" & cell1.Row).Interior.ColorIndex = 42
                    ws2.Range("D" & cell2.Row) = ws1.Range("C" & cell1.Row) - ws2.Range("C" & cell2.Row)
            End Select
        End If
    Next
Next

' Sort ws1
With ws1.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow1)
    .Header = xlYes
    .Apply
End With
   
' Sort ws2
With ws2.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow2)
    .Header = xlYes
    .Apply
End With

' Return cursor to cell A1 for each worksheet
Application.Goto ws2.Range("A1"), True
Application.Goto ws1.Range("A1"), True
       
Application.ScreenUpdating = True

End Sub
Hello, I am trying to do another reconciliation process but same layer with over 9000 line items but excel is not responding. Any ideas or suggestion?
 
Upvote 0
Hello, I am trying to do another reconciliation process but same layer with over 9000 line items but excel is not responding. Any ideas or suggestion?
No idea, but even mine 2016 from time to time not responding. I just wait for a while and then either became comlete or continuing . My data even mush shorter than that. Something that hardly happened in my old Excel 2003 ?. Even the same program running on my new 2016 64bit took more than twice the time than running on 2003 :unsure:
 
Upvote 0
No idea, but even mine 2016 from time to time not responding. I just wait for a while and then either became comlete or continuing . My data even mush shorter than that. Something that hardly happened in my old Excel 2003 ?. Even the same program running on my new 2016 64bit took more than twice the time than running on 2003 :unsure:
I am doing it manually right now and put the différence on a pivot table but it would’ve been nice if vba works without freezing my computer or excel.
 
Upvote 0
I am doing it manually right now and put the différence on a pivot table but it would’ve been nice if vba works without freezing my computer or excel.
I'm working on using either array or dictionary in which comparison is done in memory instead of reading in sheet. This should be faster.
 
Upvote 0
I'm working on using either array or dictionary in which comparison is done in memory instead of reading in sheet. This should be faster.
Thank you in advance
 
Upvote 0
Try this

VBA Code:
Sub Compare_Difference2()

Dim n&, eRow1&, eRow2&
Dim key1 As Variant, key2 As Variant
Dim cell As Range
Dim DictA As Object, DictB As Object
Dim ws1 As Worksheet, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

Set DictA = CreateObject("Scripting.Dictionary")
Set DictB = CreateObject("Scripting.Dictionary")

' Get last row for each data on Sheet1 and Sheet2
eRow1 = ws1.Range("A1").End(xlDown).Row
eRow2 = ws2.Range("A1").End(xlDown).Row

' Fill Dictionary
For n = 2 To eRow1
    DictA.Add n, ws1.Range("A" & n) & " " & ws1.Range("B" & n)
Next
For n = 2 To eRow2
    DictB.Add n, ws2.Range("A" & n) & " " & ws2.Range("B" & n)
Next

ws1.Range("D1") = "Diff (Sht2 - Sht1)"
For Each key1 In DictA
    For Each key2 In DictB
        If DictB(key2) = DictA(key1) Then
            If ws2.Range("C" & key2) = ws1.Range("C" & key1) Then
                ws2.Range("A" & key2, "C" & key2).Interior.ColorIndex = 6
            Else
                ws2.Range("A" & key2, "B" & key2).Interior.ColorIndex = 6
                ws1.Range("D" & key1) = ws2.Range("C" & key2) - ws1.Range("C" & key1)
            End If
        End If
    Next
Next

ws2.Range("D1") = "Diff (Sht1 - Sht2)"
For Each key2 In DictB
    For Each key1 In DictA
        If DictA(key1) = DictB(key2) Then
            If ws1.Range("C" & key1) = ws2.Range("C" & key2) Then
                ws1.Range("A" & key1, "C" & key1).Interior.ColorIndex = 42
            Else
                ws1.Range("A" & key1, "B" & key1).Interior.ColorIndex = 42
                ws2.Range("D" & key2) = ws1.Range("C" & key1) - ws2.Range("C" & key2)
            End If
        End If
    Next
Next

' Sort ws1
With ws1.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow1)
    .Header = xlYes
    .Apply
End With
    
' Sort ws2
With ws2.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow2)
    .Header = xlYes
    .Apply
End With

' Return cursor to cell A1 for each worksheet
Application.Goto ws2.Range("A1"), True
Application.Goto ws1.Range("A1"), True
        
Application.ScreenUpdating = True
            
End Sub
 
Upvote 0
Try this

VBA Code:
Sub Compare_Difference2()

Dim n&, eRow1&, eRow2&
Dim key1 As Variant, key2 As Variant
Dim cell As Range
Dim DictA As Object, DictB As Object
Dim ws1 As Worksheet, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

Set DictA = CreateObject("Scripting.Dictionary")
Set DictB = CreateObject("Scripting.Dictionary")

' Get last row for each data on Sheet1 and Sheet2
eRow1 = ws1.Range("A1").End(xlDown).Row
eRow2 = ws2.Range("A1").End(xlDown).Row

' Fill Dictionary
For n = 2 To eRow1
    DictA.Add n, ws1.Range("A" & n) & " " & ws1.Range("B" & n)
Next
For n = 2 To eRow2
    DictB.Add n, ws2.Range("A" & n) & " " & ws2.Range("B" & n)
Next

ws1.Range("D1") = "Diff (Sht2 - Sht1)"
For Each key1 In DictA
    For Each key2 In DictB
        If DictB(key2) = DictA(key1) Then
            If ws2.Range("C" & key2) = ws1.Range("C" & key1) Then
                ws2.Range("A" & key2, "C" & key2).Interior.ColorIndex = 6
            Else
                ws2.Range("A" & key2, "B" & key2).Interior.ColorIndex = 6
                ws1.Range("D" & key1) = ws2.Range("C" & key2) - ws1.Range("C" & key1)
            End If
        End If
    Next
Next

ws2.Range("D1") = "Diff (Sht1 - Sht2)"
For Each key2 In DictB
    For Each key1 In DictA
        If DictA(key1) = DictB(key2) Then
            If ws1.Range("C" & key1) = ws2.Range("C" & key2) Then
                ws1.Range("A" & key1, "C" & key1).Interior.ColorIndex = 42
            Else
                ws1.Range("A" & key1, "B" & key1).Interior.ColorIndex = 42
                ws2.Range("D" & key2) = ws1.Range("C" & key1) - ws2.Range("C" & key2)
            End If
        End If
    Next
Next

' Sort ws1
With ws1.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow1)
    .Header = xlYes
    .Apply
End With
   
' Sort ws2
With ws2.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Range("A1", "D" & eRow2)
    .Header = xlYes
    .Apply
End With

' Return cursor to cell A1 for each worksheet
Application.Goto ws2.Range("A1"), True
Application.Goto ws1.Range("A1"), True
       
Application.ScreenUpdating = True
           
End Sub
Still crashing or (Not Responding)
 
Upvote 0

Forum statistics

Threads
1,213,506
Messages
6,114,025
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top