CODEWITHSUNDEEP
excelvbavlookupxlookup
mojo_jojo_12
mojo_jojo_12

Reputation: 11

Compare two excel sheets for missing and new data in Sheet 2 from Sheet 1

I have two excel sheets with numerous rows and columns. Sheet 1 is the baseline sheet and Sheet 2 is the new datasheet. I would like to compare both the sheets and see what data is missing in Sheet 2 and what new data has been added in Sheet 2. The rows would be mismatched for values when any row is added/deleted in Sheet 2.

I have created a macro to concatenate Col A thru E and show the results in Col H on both sheets as the first step. Now I need to create a macro in Sheet 3 that would compare Col H in both sheets and show results as missing data (Sheet3:Col C) and new data (Sheet3:Col D). (Sheet3:Col A) and (Sheet3:Col B) would be the concatenated COL H from Sheet 1 and Sheet 2 respectively. I currently have a macro that is showing false positives even when the parts are present in Sheet 1.

Sub MacroCompare()
'
' MacroCompare Macro
'

'
    Sheets("baseline").Select
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "baseline"
    Columns("H:H").Select
    Selection.Copy
    Sheets("Comparison").Select
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("baselinecopy").Select
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("test").Select
    Range("H1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "test"
    Columns("H:H").Select
    Selection.Copy
    Sheets("Comparison").Select
    Columns("B:B").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("testcopy").Select
    Columns("A:A").Select
    Range("A43").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Comparison").Select
    Range("C1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "missing"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "extras"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(baselinecopy!RC[-2],testcopy!R2C1:R7443C1,1,FALSE)"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C7443")
    Range("C2:C7443").Select
    Range("D2").Select
    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(testcopy!RC[-3],baselinecopy!R2C1:R7443C1,1,FALSE)"
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D7443")
    Range("D2:D7443").Select
End Sub

Upvotes: 0

Views: 663

Answers (1)

CDP1802
CDP1802

Reputation: 16174

Store the concatenated columns as keys in a Dictionary Object.

Option Explicit

Sub MacroCompare()

    Const C = "~" ' concatenation character

    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim iLastRow As Long, iCompare As Long
    Dim addCount As Long, deleteCount As Long
    Dim r As Long, i As Integer, s As String, ar

    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets(1) ' baseline
    Set ws2 = wb.Sheets(2) ' test

    Dim dict, k
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' scan baseline build dictionary
    iLastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To iLastRow
        ' concatenate
        ar = ws1.Cells(r, "A").Resize(1, 5) ' A to E
        k = ar(1, 1)
        For i = 2 To UBound(ar, 2)
            k = k & C & ar(1, i)
        Next

        If dict.exists(k) Then
            MsgBox "Duplicate key '" & k & "'", vbCritical, "Error Row " & r
            Exit Sub
        Else
            dict.Add k, r
        End If
    Next

    ' scan test for items not in dictionary
    Set ws3 = wb.Sheets(3) ' compare
    ws3.Cells.Clear
    ws3.Range("A1:I1") = Array("Sht1", "Sht2", "A", "B", "C", "D", "E", "Del", "Add")
    iCompare = 1

    iLastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To iLastRow
        ar = ws2.Cells(r, "A").Resize(1, 5) ' A to E
        k = ar(1, 1)
        For i = 2 To UBound(ar, 2)
            k = k & C & ar(1, i)
        Next
        
        If dict.exists(k) Then
            dict.Remove k
        Else
            iCompare = iCompare + 1
            ws3.Cells(iCompare, "B") = k '"Row " & r
            ws3.Cells(iCompare, "C").Resize(1, 5) = Split(k, C)
            ws3.Cells(iCompare, "I") = "Added"
            'ws2.Cells(r, "A").Interior.Color = vbGreen
            addCount = addCount + 1
        End If
    Next

    ' show deleted
    For Each k In dict
        r = dict(k)
        iCompare = iCompare + 1
        ws3.Cells(iCompare, "A") = k '"Row " & r
        ws3.Cells(iCompare, "C").Resize(1, 5) = Split(k, C)
        ws3.Cells(iCompare, "H") = "Deleted"
        'ws1.Cells(r, "A").Interior.Color = vbRed
        deleteCount = deleteCount + 1
    Next
 
   ' result
    s = "added = " & addCount & vbCrLf & _
        "deleted = " & deleteCount
    MsgBox s, vbInformation

End Sub

Upvotes: 0

Related Questions