Comparing 2 datasets for reconciliation using VBA

B

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!
 
Sort by date Sort by votes
Zot said:
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
Click to expand...
It works. Thank you so much for your help!
 
Upvote 0

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Zot said:
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
Click to expand...
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
Zot said:
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
Click to expand...
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
BigMo1987 said:
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?
Click to expand...
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
Zot said:
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:
Click to expand...
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
BigMo1987 said:
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.
Click to expand...
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
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
Zot said:
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
Click to expand...
Still crashing or (Not Responding)
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
Comparing two different worksheets/datasets
Replies
1
Views
519
HighAndWilder
H
M
  • Solved
VBA to Insert Mismatched Row in separate worksheet
2 3
Replies
21
Views
753
Peter_SSs
Peter_SSs
MrIfOnly
  • Question Question
shapes.onaction in add-in using reference path to macro (Excel VBA)
Replies
8
Views
57
jkpieterse
jkpieterse
J
  • Question Question
Copy of screen shot to sent to email is chopping off the last few columns
Replies
4
Views
126
JannetteChristie
J
M
  • Question Question
Conditional Formatting/Moving Rows Based on Matching and Opposite Data
Replies
1
Views
241
Madam_Xavier
M

Forum statistics

Threads
1,223,901
Messages
6,175,277
Members
452,629
Latest member
SahilPolekar

Share this page

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