1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. 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...

  3. 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

Discussion in 'VBA Macros' started by Payroll Mike, Apr 19, 2017.

  1. Payroll Mike

    Payroll Mike New Member

    Messages:
    4
    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 (vb):

    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
     

    Attached Files:

  2. Payroll Mike

    Payroll Mike New Member

    Messages:
    4
    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 (vb):


    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 !

  3. Chihiro

    Chihiro Well-Known Member

    Messages:
    3,015
    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.
    Payroll Mike likes this.
  4. Payroll Mike

    Payroll Mike New Member

    Messages:
    4
    I am using 2010 for office.

    Sadly, i do not have PowerQuery

    Please see attached for a better understanding.

    Attached Files:

  5. Marc L

    Marc L Excel Ninja

    Messages:
    2,916

    Hi !

    « For a better understanding » explain each possible case at least …
    Payroll Mike likes this.
  6. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,416
    Hi!
    I think that the code at the OP seems a bit familiar to me...
    Regards!
    Payroll Mike likes this.
  7. Marc L

    Marc L Excel Ninja

    Messages:
    2,916
    SirJB7, it's been a while … Carlsberg ! :cool:

    Mike, as a starter according to your last attachment :​
    Code (vb):
    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 !
    Payroll Mike likes this.
  8. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,416
    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!
    Payroll Mike likes this.
  9. Payroll Mike

    Payroll Mike New Member

    Messages:
    4
    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
  10. Marc L

    Marc L Excel Ninja

    Messages:
    2,916
    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

Share This Page