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
The file you sent basically just duplicate of the other cell and additional row. I tried to copy paste column C randomly to see if it really works. I have no idea if the results are correct, but the code is based on old one with minor modification. I just deleted the the one already found so that the second data will get faster and faster to search as it approaching the end.. It took just 35s to complete.

VBA Code: 
Sub Compare_Difference3()

Dim n&, eRow1&, eRow2&
Dim StartTime#, SecondsElapsed#
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

StartTime = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

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
                DictB.Remove key2
                Exit For
            Else
                ws2.Range("A" & key2, "B" & key2).Interior.ColorIndex = 6
                ws1.Range("D" & key1) = ws2.Range("C" & key2) - ws1.Range("C" & key1)
                Exit For
            End If
        End If
    Next
Next

DictB.RemoveAll
For n = 2 To eRow2
    DictB.Add n, ws2.Range("A" & n) & " " & ws2.Range("B" & n)
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
                DictA.Remove key1
                Exit For
            Else
                ws1.Range("A" & key1, "B" & key1).Interior.ColorIndex = 42
                ws2.Range("D" & key2) = ws1.Range("C" & key1) - ws2.Range("C" & key2)
                Exit For
            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
Application.Calculation = xlCalculationAutomatic

'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
            
End Sub
 
Upvote 0

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Zot said:
The file you sent basically just duplicate of the other cell and additional row. I tried to copy paste column C randomly to see if it really works. I have no idea if the results are correct, but the code is based on old one with minor modification. I just deleted the the one already found so that the second data will get faster and faster to search as it approaching the end.. It took just 35s to complete.

VBA Code: 
Sub Compare_Difference3()

Dim n&, eRow1&, eRow2&
Dim StartTime#, SecondsElapsed#
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

StartTime = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

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
                DictB.Remove key2
                Exit For
            Else
                ws2.Range("A" & key2, "B" & key2).Interior.ColorIndex = 6
                ws1.Range("D" & key1) = ws2.Range("C" & key2) - ws1.Range("C" & key1)
                Exit For
            End If
        End If
    Next
Next

DictB.RemoveAll
For n = 2 To eRow2
    DictB.Add n, ws2.Range("A" & n) & " " & ws2.Range("B" & n)
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
                DictA.Remove key1
                Exit For
            Else
                ws1.Range("A" & key1, "B" & key1).Interior.ColorIndex = 42
                ws2.Range("D" & key2) = ws1.Range("C" & key1) - ws2.Range("C" & key2)
                Exit For
            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
Application.Calculation = xlCalculationAutomatic

'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
           
End Sub
Click to expand...
The sample file is the same count of line and trying to get the same result. This is still not working for me. Is there any other application that i can use to automate this reconciliation with a loop summary?
 
Upvote 0
I ran on the file you provided. For sheet1 all rows are highlighted. For sheet2, all rows are highlighted until same row number as sheet1 which is 98411. Then the rest of rows until 98427 are not highlighted. I believe this is correct.

Just what you meant by not working? Still crashed? Just now I ran the macro and still showed (not responding) but after that still completed in about 12 seconds. I don;t know why it is still not working for you.
 
Upvote 0
Zot said:
I ran on the file you provided. For sheet1 all rows are highlighted. For sheet2, all rows are highlighted until same row number as sheet1 which is 98411. Then the rest of rows until 98427 are not highlighted. I believe this is correct.

Just what you meant by not working? Still crashed? Just now I ran the macro and still showed (not responding) but after that still completed in about 12 seconds. I don;t know why it is still not working for you.
Click to expand...
Not responding for me. Running after 20min and still saying on top not responding.
 
Upvote 0
BigMo1987 said:
Not responding for me. Running after 20min and still saying on top not responding.
Click to expand...
:unsure: I have no idea.

Mine is only Excel 2016 64 bit. Core i5-6500 desktop only. Old processor with just 4GB RAM. Windows 7 64 bit
 
Upvote 0
That is too long about 45min ?. What is your computer spec? Cannot be older than mine. Perhaps something is different with Excel 365? Right now I can't think of any other way to reduce mine to 1s ?

On positive side, I still prefer taking a break for 45 min than doing manually for 45 min. How long does it take to compile normally.

Well if you need to compare only one way, just remark out the reverse comparison and cut the time to half.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Comparing two different worksheets/datasets
Replies
1
Views
259
HighAndWilder
H
P
  • Question
Code used for comparison between 2 list.
Replies
3
Views
306
Tupe77
T
K
  • Question
Excel VBA - migrating from Windows to macOS
Replies
2
Views
385
kreutz
K
B
  • Question
Excel VBA When new rows are added to table 1 copy the information to table 2
Replies
0
Views
413
BlueHawker42
B
A
  • Question
Dynamically add new rows via VBA when using IFERROR TEXTJOIN and FILTER formulas from Table?
Replies
0
Views
61
AlfredDB
A

Forum statistics

Threads
1,214,854
Messages
6,121,941
Members
449,056
Latest member
denissimo

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