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 Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
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 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