• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Comparing two spreadsheets for changes and return sheet 3 differences

P

Payroll Mike

New Member
Hi there,

So, i have a code started from another thread, but i am still running into issues. I need to compare to tabs of data and have a third tab generate the issues. All columns will be the same. I would need the formula to utilize the WorkdayID as the unique identifier as the order of the data will always be different on the two tabs Attached a sample of the reports). Please let me know if more information is needed and than kyou for your time with this matter.
-Mike

Code: 
Option Explicit

Sub CompareSheets()
'
' constants
' worksheets & ranges
' original
Const ksWSOriginal = "ORIGINAL"
Const ksOriginal = "OriginalTable"
Const ksOriginalKey = "OriginalKey"
' updated
Const ksWSUpdated = "UPDATED"
Const ksUpdated = "UpdatedTable"
Const ksUpdatedKey = "UpdatedKey"
' changes
Const ksWSChanges = "CHANGES"
Const ksChanges = "ChangesTable"
' labels
Const ksChange = "CHANGE"
Const ksRemove = "REMOVE"
Const ksAdd = "ADD"
'
' declarations
Dim rngO As Range, rngOK As Range, rngU As Range, rngUK As Range, rngC As Range
Dim c As Range
Dim i As Long, J As Long, lChanges As Long, lRow As Long, bEqual As Boolean
'
' start
Set rngO = Worksheets(ksWSOriginal).Range(ksOriginal)
Set rngOK = Worksheets(ksWSOriginal).Range(ksOriginalKey)
Set rngU = Worksheets(ksWSUpdated).Range(ksUpdated)
Set rngUK = Worksheets(ksWSUpdated).Range(ksUpdatedKey)
Set rngC = Worksheets(ksWSChanges).Range(ksChanges)
With rngC
    If .Rows.Count > 1 Then
        Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
        Range(.Rows(2), .Rows(.Rows.Count)).Font.ColorIndex = xlColorIndexAutomatic
        Range(.Rows(2), .Rows(.Rows.Count)).Font.Bold = False
    End If
End With
'
' process
lChanges = 1
' 1st pass: updates & deletions
With rngOK
    For i = 1 To .Rows.Count
        Set c = rngUK.Find(.Cells(i, 1).Value, , xlValues, xlWhole)
        If c Is Nothing Then
            ' deletion
           lChanges = lChanges + 1
            rngC.Cells(lChanges, 1).Value = ksRemove
            For J = 1 To rngO.Columns.Count
                rngC.Cells(lChanges, J + 1).Value = rngO.Cells(i, J).Value
                rngC.Cells(lChanges, J + 1).Font.Color = vbRed
                rngC.Cells(lChanges, J + 1).Font.Bold = True
            Next J
        Else
            bEqual = True
            lRow = c.Row - rngUK.Row + 1
            For J = 1 To rngO.Columns.Count
                If rngO.Cells(i, J).Value <> rngU.Cells(lRow, J).Value Then
                    bEqual = False
                    Exit For
                End If
            Next J
            If Not bEqual Then
                ' change
               lChanges = lChanges + 1
                rngC.Cells(lChanges, 1).Value = ksChange
                For J = 1 To rngO.Columns.Count
                    If rngO.Cells(i, J).Value = rngU.Cells(lRow, J).Value Then
                        rngC.Cells(lChanges, J + 1).Value = rngO.Cells(i, J).Value
                    Else
                        rngC.Cells(lChanges, J + 1).Value = rngU.Cells(i, J).Value
                        rngC.Cells(lChanges, J + 1).Font.Color = vbMagenta
                        rngC.Cells(lChanges, J + 1).Font.Bold = True
                    End If
                Next J
            End If
        End If
    Next i
End With
' 2nd pass: additions
With rngUK
    For i = 1 To .Rows.Count
        Set c = rngOK.Find(.Cells(i, 1).Value, , xlValues, xlWhole)
        If c Is Nothing Then
            ' addition
           lChanges = lChanges + 1
            rngC.Cells(lChanges, 1).Value = ksAdd
            For J = 1 To rngU.Columns.Count
                rngC.Cells(lChanges, J + 1).Value = rngU.Cells(i, J).Value
                rngC.Cells(lChanges, J + 1).Font.Color = vbBlue
                rngC.Cells(lChanges, J + 1).Font.Bold = True
            Next J
        End If
    Next i
End With
'
' end
Worksheets(ksWSChanges).Activate
rngC.Cells(2, 3).Select
Set rngC = Nothing
Set rngUK = Nothing
Set rngU = Nothing
Set rngOK = Nothing
Set rngO = Nothing
Beep
'
End Sub
 

Attachments

update: came up with this solution but not sure how to only have it return changes. Also, If data is on the "workday" tab and not on the "ADP" tab (such as new hires) i need these to generate on the changes tab as well.

Thank you!

Code: 
Option Explicit

Sub matchTwosheets1()
Dim x, y, i&, j&, k&, Z, ws1 As Worksheet

      If Not Evaluate("ISREF('" & "Compare" & "'!A1)") Then
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Compare"
            Set ws1 = ActiveSheet
      Else
             Set ws1 = Worksheets("Compare")
              With ws1.Range("A2").CurrentRegion
                .ClearContents
                .Interior.ColorIndex = xlNone
              End With
      End If
   
    With Worksheets("WORKDAY").Range("A2").CurrentRegion
        x = .Value
    End With
        With CreateObject("scripting.dictionary")
            .comparemode = 1
            For i = 1 To UBound(x, 1)
                .Item(Trim(x(i, 1))) = i
            Next
           With Worksheets("ADP").Range("A2").CurrentRegion
              y = .Value
           End With
           ReDim Z(1 To UBound(y, 1), 1 To UBound(y, 2))
            For i = 1 To UBound(y, 1)
                    If .exists(Trim(y(i, 1))) Then
                        k = .Item(Trim(y(i, 1)))
                         For j = 1 To UBound(y, 2)
                            If Trim(y(i, j)) <> Trim(x(k, j)) Then
                                Z(i, j) = y(i, j)
                                ws1.Cells(i, j).Interior.ColorIndex = 5
                            Else
                                Z(i, j) = y(i, j)
                            End If
                         Next j
                    End If
            Next i
        End With
           With ws1
            .Range("A1").Resize(i - 1, UBound(Z, 2)) = Z
            .Columns.AutoFit
          End With
End Sub


▬▬▬▬▬▬▬▬▬ Mod edit : thread moved to appropriate forum !
​
 
What version of Excel do you have? And do you have access to Get & Transform (i.e. PowerQuery)?

PowerQuery makes this sort of operation simple. If you don't have access to it, MS Query, or ADO in VBA can do same thing.

But I'd recommend you give more than single row of data as sample. Including expected output.
 
SirJB7, it's been a while … Carlsberg ! :cool:

Mike, as a starter according to your last attachment :​
Code: 
Sub Demo()
     Dim Ra As Range, Rw As Range, N&, L&, R&, V, B%, C&
     Set Ra = Worksheets(1).[A1].CurrentRegion
     Set Rw = Worksheets(2).[A1].CurrentRegion.Rows
          N = Rw.Columns.Count
          L = 1
With Worksheets(3)
        .UsedRange.Offset(1).Clear
        Application.ScreenUpdating = False
    For R = 2 To Rw.Count
            V = Application.Match(Rw(R).Cells(1).Value, Ra.Columns(1), 0)
        If IsError(V) Then
            L = L + 1
            Rw(R).Copy .Cells(L, 1)
            .Cells(L, 1).Resize(, N).Font.Bold = True
        Else
                B = 1
            For C = 2 To N
                If Rw(R).Cells(C).Value <> Ra.Cells(V, C).Value Then
                    If B Then L = L + 1: Rw(R).Copy .Cells(L, 1): B = 0
                    .Cells(L, C).Font.Bold = True
                End If
            Next
        End If
    Next
        Application.ScreenUpdating = True
End With
    Set Ra = Nothing:  Set Rw = Nothing
End Sub
Do you like it ? So thanks to click on bottom right Like !
​
 
Hi, Marc L!
Refresh my memory if you don't mind... The Like button is still being used to give thanks for Carlsberg's six-pack or has it another not so charming usage?
Regards!
 
Marc L,

Thank you kindly for your help.

This is a great start as it is pulling back the added line for new hires and bolding all the changes.

Is there a way to have it only pull back the bolded items on Worksheet 3?

Thank you again!
Mike
 
According to your explanation, my code returns any change
and entire row of second worksheet if its ID does not exists in first one.

If not solved, so well read post #5 !
And as a starter ('cause of unclear explanation vs attachment),
you can mod my code to your convenience …

SirJB7, you killed me softly ‼ :DD
​
 
You must log in or register to reply here.
Back
Top