none
compare data in excel RRS feed

  • Question

  • regards
    I have two excel sheets in the same book, each sheet has around 6000 records in four columns

    I need is to compare if the data is the same in both sheets

    thanks in advance

    Wednesday, May 25, 2016 6:01 PM

All replies

  • Hi Augusto C,

    please try to use the code below. it will help you to compare the 2 sheets in same Excel Workbook.

    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
      

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Thursday, May 26, 2016 3:45 AM
    Moderator