Compare two sheets with rows inserted and data upated

[michellems]

Hi Everyone!

I've been working on this problem for a while and I still can't figure it out. Essentially I will be taking a snapshot of data, and then comparing it to new data months later to find out what changed. I need a <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-bottom-style: dotted; border-bottom-color: rgb(0, 0, 0); cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym> code to highlight these differences in:
1) data in the existing item changes 2) data newly added

Sample raw data in worksheet Original:
Excel 2010

	A	B	C	D	E	F
1	Number	Age	Gender	Height (in)	Weight (lb)	Comments
2	001	21	M	72	182	good in sports
3	002	23	F	69	120	weak in maths
4	003	35	M	70	175	like doing sports
5	004	31	F	65	140	playful
6	005	27	F	66	147	hardworking girl
7
8

<colgroup><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Original

​

Sample raw data in worksheet New:

	A	B	C	D	E	F	G
1	Number	Age	Gender	Weight (lb) <tbody> </tbody>
2	003	21	M	72	181
3	004	24	F	80	120
4	005	35	F	70	180
5	006	29	M	75	186
6	007	31	F	65	140
7
8
9

<colgroup><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

New​

And, after the macro:
Excel 2010

	A	B	C	D	E	F	G
1	Number	Age	Gender	Weight (lb) <tbody> </tbody>

<colgroup><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>

</tbody>

</td>[TD]

Comments​

[/TD]
[TD="align: right"][/TD]
</tr>[TR]
[TD="align: center"]2[/TD]
[TD]001[/TD]
[TD="align: right"]21[/TD]
[TD]M[/TD]
[TD="align: right"]72[/TD]
[TD="align: right"]182[/TD]
[TD="align: right"]good in sports[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]3[/TD]
[TD]002[/TD]
[TD="align: right"]23[/TD]
[TD]F[/TD]
[TD="align: right"]69[/TD]
[TD="align: right"]120[/TD]
[TD="align: right"]weak in maths[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]4[/TD]
[TD]003[/TD]
[TD="align: right"]21[/TD]
[TD]M[/TD]
[TD="align: right"]72[/TD]
[TD="align: right"]181[/TD]
[TD="align: right"]like doing sports[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]5[/TD]
[TD]004[/TD]
[TD="align: right"]24[/TD]
[TD]F[/TD]
[TD="align: right"]80[/TD]
[TD="align: right"]120[/TD]
[TD="align: right"]playful[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]6[/TD]
[TD]005[/TD]
[TD="align: right"]31[/TD]
[TD]F[/TD]
[TD="align: right"]70[/TD]
[TD="align: right"]180[/TD]
[TD="align: right"]hardworking girl[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]7[/TD]
[TD]006[/TD]
[TD="align: right"]29[/TD]
[TD]M[/TD]
[TD="align: right"]75[/TD]
[TD="align: right"]186[/TD]
[TD="align: right"]
[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]8[/TD]
[TD]007[/TD]
[TD="align: right"]31[/TD]
[TD]F[/TD]
[TD="align: right"]65[/TD]
[TD="align: right"]140[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]9[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[/TR]
</tbody>

New​

 

[Teeroy]

Try the following on a COPY of your data (as VBA changes generally cannot be undone). It assumes that you data begins in Row 2 on both sheets.

Sub compare_and_highlight_different_data()
Dim vCompare, vMatch, vCompareItemData
Dim i As Long, j As Integer, LRNew As Long, LROrignal As Long

With Sheets("New")
    LRNew = .Range("A" & .Rows.Count).End(xlUp).Row
    LROriginal = Sheets("Original").Range("A" & .Rows.Count).End(xlUp).Row
    vCompare = .Range("A2:E" & LRNew)
    
    For i = 1 To UBound(vCompare)
        If Not IsError(Application.Match(vCompare(i, 1), Sheets("Original").Range("A2:A" & LROriginal), 0)) Then
            vMatch = Application.Match(vCompare(i, 1), Sheets("Original").Range("A2:A" & LROriginal), 0)
            For j = 1 To 5
                If Sheets("Original").Cells(vMatch + 1, j) <> vCompare(i, j) Then
                    .Cells(i + 1, j).Font.Color = vbRed
                End If
            Next j
        Else
            .Cells(i + 1, 1).Resize(, 5).Font.Color = vbRed
        End If
    Next i
End With
End Sub

 

[michellems]

Dear Teeroy,

Thank you very much for your code!! It runs smoothly
It works in showing the difference between "New" and "Original" sheet and highlighted in red!

But the row with number "001" and "002" are missing, are there any commands that I can also move the old records "001 and 002" to the "New" Sheet?

Thanks a lot ind

 

[Teeroy]

Dear Teeroy,

Thank you very much for your code!! It runs smoothly
It works in showing the difference between "New" and "Original" sheet and highlighted in red!

But the row with number "001" and "002" are missing, are there any commands that I can also move the old records "001 and 002" to the "New" Sheet?

Thanks a lot ind

Please try to make sure that you've listed all your requirements up front. Sometimes adding a new requirement makes it necessary to completely re-write the code, not just make a minor change.

Try the following, again on a copy...

Sub compare_and_highlight_different_data2()
Dim vCompare, vMatch, vCompareItemData, vPrimaryKey
Dim i As Long, j As Integer, LRNew As Long, LROrignal As Long
Dim objNewData As Object
Dim rMatch As Range

Set objNewData = CreateObject("Scripting.Dictionary")

With Sheets("New")
    LRNew = .Range("A" & .Rows.Count).End(xlUp).Row
    LROriginal = Sheets("Original").Range("A" & .Rows.Count).End(xlUp).Row
    vCompare = .Range("A2:E" & LRNew)
    'reset all font colors
    .Cells.Font.Color = vbBlack
    
    For i = 1 To UBound(vCompare)
        'make list of new data in a Dictionary
        objNewData.Add vCompare(i, 1), i + 1
        If Not IsError(Application.Match(vCompare(i, 1), Sheets("Original").Range("A2:A" & LROriginal), 0)) Then
            ' if matching primary key is found in original
            ' check all  data in  the row
            vMatch = Application.Match(vCompare(i, 1), Sheets("Original").Range("A2:A" & LROriginal), 0)
            For j = 1 To 5
                If Sheets("Original").Cells(vMatch + 1, j).Value <> vCompare(i, j) Then
                    .Cells(i + 1, j).Font.Color = vbRed
                End If
            Next j
        Else
            ' if no matching data is in the orignal highlight the new row
            .Cells(i + 1, 1).Resize(, 5).Font.Color = vbRed
        End If
    Next i
End With
'check original data for data not in "New" sheet and copy accross
With Sheets("Original")
    vCompare = .Range("A2:A" & LROriginal)
    For Each vPrimaryKey In vCompare
       If Not objNewData.exists(vPrimaryKey) Then
            LRNew = LRNew + 1
            ' handle the formatting of the string number being coerced into a number
            Sheets("New").Cells(LRNew, 1).NumberFormat = "@"
            vMatch = Application.Match(vPrimaryKey, .Range("A2:A" & LROriginal), 0) + 1
            Set rMatch = .Range("A" & vMatch).Resize(1, 5)
            Sheets("New").Cells(LRNew, 1).Resize(1, 5).Value = rMatch.Value
        End If
    Next
End With
End Sub

 

[michellems]

Dear Teeroy,

Sorry to make you confused, Thanks very much for the codes! It works perfectly!
Many thanks!!!

michelle

 

[Teeroy]

You're welcome.