Dynamic VBA - Compare Tables on 2 Sheets for Differences

[KristianH]

I am new to VBA and was looking for help in writing a code that can compare two tables on 2 different sheets and show the difference.
The code need to be used on different tables that have diffrent sizes eg. one time the tables use collumn A to C and another time it can use A to K.

I have looked at ways to do it, but get really confused when I try to make it dynamic. I want it to find items that are missing from sheet "Old_Data" and add that entire row to sheet "Output"

Here's an example of what I am looking for given 2 sheets of data, and the final output.

Sheet: Old_Data

1A	A1	AA
2B	B2	BB
3C	C3	CC
4D	D4
5E	E5	EE

Sheet: New_Data

1A	A1	AA
3C	C3	CC
2B	B2	CC
4D	D4	DD
6E	E6	EE

Sheet: Output

4D	D4	DD
6E	E6	EE

Thank you so much for the help

 

[KristianH]

I have modified this code, but it replace the data in New_Data instead of copy the difference to Output.

Sub DeleteRows()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim rng As Range, rng2 As Range, f As Range, c As Range, var1 As Range, var2 As Range
  Dim cad As String
  Dim col1 As Long, col2 As Long, i As Long, hrow As Long
  Dim dic As Object
  
  'Fit to your data
  Set sh1 = Sheets("New_Data")
  Set sh2 = Sheets("Old_Data")
  Set var1 = sh1.Range("A1")    'On Sheet 1, Cell where header is (Variable1)
  Set var2 = sh1.Range("B1")    'On sheet 1, Cell where header is (Variable2)
  hrow = 1                      'single header row in sheet 2
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  Set f = sh2.Rows(hrow).Find(var1.Value, , xlValues, xlWhole, , , False)
  If f Is Nothing Then MsgBox "Header " & var1 & " does not exist in sheet 2": Exit Sub
  col1 = f.Column
  Set f = sh2.Rows(hrow).Find(var2.Value, , xlValues, xlWhole, , , False)
  If f Is Nothing Then MsgBox "Header " & var2 & " does not exist in sheet 2": Exit Sub
  col2 = f.Column
  
  For Each c In sh2.Range(sh2.Cells(2, col1), sh2.Cells(Rows.Count, col1).End(3))
    dic(c.Value & "|" & sh2.Cells(c.Row, col2).Value) = Empty
  Next
  
  For i = var1.Row + 1 To sh1.Cells(Rows.Count, var1.Column).End(3).Row
    cad = sh1.Cells(i, var1.Column).Value & "|" & sh1.Cells(i, var2.Column).Value
    Set rng2 = Union(sh1.Cells(i, var1.Column), sh1.Cells(i, var2.Column))
    If dic.exists(cad) Then
      If rng Is Nothing Then Set rng = rng2 Else Set rng = Union(rng, rng2)
    End If
  Next
  
  If Not rng Is Nothing Then
    Application.ScreenUpdating = False
    rng.EntireRow.Delete
  End If
End Sub

 

[Marc L]

According to the initial post sample an Excel basics VBA demonstration for starters to paste only to the Output worksheet module :​

Sub Demo1()
  Const S = "&""¤""&"
    Dim A$, F$, V
        UsedRange.Clear
    With Sheets("Old_Data").[A1].CurrentRegion.Columns
        F = .Item(1).Address(, , , True) & S & .Item(2).Address(, , , True) & S & .Item(3).Address(, , , True)
    End With
    With Sheets("New_Data").[A1].CurrentRegion.Columns
        F = "TRANSPOSE(IF(ISNA(MATCH(" & .Item(1).Address & S & .Item(2).Address & S & .Item(3).Address & "," & F
        V = Filter(.Parent.Evaluate(F & ",0)),ROW(" & .Item(1).Address & ")))"), False, False)
        If UBound(V) > -1 Then Range("A1:C" & UBound(V) + 1).Value2 = Application.Index(.Value2, Application.Transpose(V), [{1,2,3}])
    End With
End Sub

 

[Marc L]

A$, should be removed from the Dim codeline …​

 

[Alex Blakenburg]

To get the 4D row in your output, you would need to put all 3 fields into your dictionary (currently only 2). If you did put all 3 fields in then you would also get the 2D row in your output since the 3rd column is different.

With only minimal changes to your code and assuming the sheet "Output" exists, try this.
It adds code for a sh3 being the Output sheet, copies the New_Data into Output then deletes the matched items as you are currently doing but using the Output sheet instead.

Sub DeleteRows()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim rng As Range, rng2 As Range, f As Range, c As Range, var1 As Range, var2 As Range
  Dim cad As String
  Dim col1 As Long, col2 As Long, i As Long, hrow As Long
  Dim dic As Object
  
  'Fit to your data
  Set sh1 = Sheets("New_Data")
  Set sh2 = Sheets("Old_Data")
  Set sh3 = Sheets("Output")
  Set var1 = sh1.Range("A1")    'On Sheet 1, Cell where header is (Variable1)
  Set var2 = sh1.Range("B1")    'On sheet 1, Cell where header is (Variable2)
  hrow = 1                      'single header row in sheet 2
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  Set f = sh2.Rows(hrow).Find(var1.Value, , xlValues, xlWhole, , , False)
  If f Is Nothing Then MsgBox "Header " & var1 & " does not exist in sheet 2": Exit Sub
  col1 = f.Column
  Set f = sh2.Rows(hrow).Find(var2.Value, , xlValues, xlWhole, , , False)
  If f Is Nothing Then MsgBox "Header " & var2 & " does not exist in sheet 2": Exit Sub
  col2 = f.Column
  
  For Each c In sh2.Range(sh2.Cells(2, col1), sh2.Cells(Rows.Count, col1).End(3))
    dic(c.Value & "|" & sh2.Cells(c.Row, col2).Value) = Empty
  Next
  
  For i = var1.Row + 1 To sh1.Cells(Rows.Count, var1.Column).End(3).Row
    cad = sh1.Cells(i, var1.Column).Value & "|" & sh1.Cells(i, var2.Column).Value
    Set rng2 = Union(sh1.Cells(i, var1.Column), sh1.Cells(i, var2.Column))
    If dic.exists(cad) Then
      If rng Is Nothing Then Set rng = rng2 Else Set rng = Union(rng, rng2)
    End If
  Next
  
  If Not rng Is Nothing Then
    Application.ScreenUpdating = False
    
    sh3.Range(sh1.UsedRange.Address).Value = sh1.UsedRange.Value
    sh3.Range(rng.Address).EntireRow.Delete
    Application.ScreenUpdating = True
  End If
End Sub

 

[Marc L]

An Excel basics VBA demonstration variation to paste only to the Output worksheet module :​

Sub Demo1v()
    Dim V, C%, Rw As Range, R&
        UsedRange.Clear
    With Sheets("Old_Data").[A1].CurrentRegion.Columns
        V = .Item(1).Address
        For C = 2 To .Count:  V = V & "&""¤""&" & .Item(C).Address:  Next
        V = .Parent.Evaluate(V)
    End With
    With Application
        .ScreenUpdating = False
    For Each Rw In Sheets("New_Data").[A1].CurrentRegion.Rows
        If .IsNA(.Match(Join(.Index(Rw.Value2, 1, 0), "¤"), V, 0)) Then R = R + 1: Rw.Copy Cells(R, 1)
    Next
        .ScreenUpdating = True
    End With
End Sub

 

[Marc L]

In case of big data Demo1 revamped :​

Sub Demo1r()
  Const S = "&""¤""&"
    Dim V, R&
        UsedRange.Clear
    With Sheets("Old_Data").[A1].CurrentRegion.Columns
        V = .Item(1).Address(, , , True) & S & .Item(2).Address(, , , True) & S & .Item(3).Address(, , , True)
    End With
        Application.ScreenUpdating = False
    With Sheets("New_Data").[A1].CurrentRegion.Columns
            V = "IF(ISNA(MATCH(" & .Item(1).Address & S & .Item(2).Address & S & .Item(3).Address & "," & V
        For Each V In .Parent.Evaluate(V & ",0)),ROW(" & .Item(1).Address & "))")
            If V Then R = R + 1: .Rows(V).Copy Cells(R, 1)
        Next
    End With
        Application.ScreenUpdating = True
End Sub

 

[KristianH]

To get the 4D row in your output, you would need to put all 3 fields into your dictionary (currently only 2). If you did put all 3 fields in then you would also get the 2D row in your output since the 3rd column is different.

With only minimal changes to your code and assuming the sheet "Output" exists, try this.
It adds code for a sh3 being the Output sheet, copies the New_Data into Output then deletes the matched items as you are currently doing but using the Output sheet instead.

Sub DeleteRows()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim rng As Range, rng2 As Range, f As Range, c As Range, var1 As Range, var2 As Range
  Dim cad As String
  Dim col1 As Long, col2 As Long, i As Long, hrow As Long
  Dim dic As Object
 
  'Fit to your data
  Set sh1 = Sheets("New_Data")
  Set sh2 = Sheets("Old_Data")
  Set sh3 = Sheets("Output")
  Set var1 = sh1.Range("A1")    'On Sheet 1, Cell where header is (Variable1)
  Set var2 = sh1.Range("B1")    'On sheet 1, Cell where header is (Variable2)
  hrow = 1                      'single header row in sheet 2
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  Set f = sh2.Rows(hrow).Find(var1.Value, , xlValues, xlWhole, , , False)
  If f Is Nothing Then MsgBox "Header " & var1 & " does not exist in sheet 2": Exit Sub
  col1 = f.Column
  Set f = sh2.Rows(hrow).Find(var2.Value, , xlValues, xlWhole, , , False)
  If f Is Nothing Then MsgBox "Header " & var2 & " does not exist in sheet 2": Exit Sub
  col2 = f.Column
 
  For Each c In sh2.Range(sh2.Cells(2, col1), sh2.Cells(Rows.Count, col1).End(3))
    dic(c.Value & "|" & sh2.Cells(c.Row, col2).Value) = Empty
  Next
 
  For i = var1.Row + 1 To sh1.Cells(Rows.Count, var1.Column).End(3).Row
    cad = sh1.Cells(i, var1.Column).Value & "|" & sh1.Cells(i, var2.Column).Value
    Set rng2 = Union(sh1.Cells(i, var1.Column), sh1.Cells(i, var2.Column))
    If dic.exists(cad) Then
      If rng Is Nothing Then Set rng = rng2 Else Set rng = Union(rng, rng2)
    End If
  Next
 
  If Not rng Is Nothing Then
    Application.ScreenUpdating = False
  
    sh3.Range(sh1.UsedRange.Address).Value = sh1.UsedRange.Value
    sh3.Range(rng.Address).EntireRow.Delete
    Application.ScreenUpdating = True
  End If
End Sub

The only problem i have now is then I change the tables it need to compare to be 8x8 or something diffrent then 3x3

 

[Alex Blakenburg]

It is unclear as to what you are trying to compare. Like I said, you have 3 columns but you only seem to be comparing on 2.
How many columns need to match and if it is not all of them, which one(s) are not to be included in the match ?

 

[Marc L]

The only problem i have now is then I change the tables it need to compare to be 8x8 or something diffrent then 3x3

Very not a problem if you have tried one of my demonstrations ! ​