Excel VBA Compare Worksheet

I found the following VBA online which compare 2 worksheets in Excel and generate the differences in the 3rd tab. I just want to modify so that it also shows the old and new value for a particular column. Attached is the pic showing the scneario.

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

Open in new window

Capture.PNG
bose3Asked:
Who is Participating?
 
Visio_GuyCommented:
I played with the code a bit. I didn't test it too heavily, but have a look.

Changes I made have '//...VG after them.

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
Dim iCol As Integer '//...VG
'
' 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
                        '// Write the original, then the updated values next to each other:
                        For iCol = 1 To 2 '//...VG added
                            rngC.Cells(lChanges, iCol).Value = rngO.Cells(I, J).Value '//...VG edited
                        Next iCol '//...VG added
                    Else
                        rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
                        rngC.Cells(lChanges, J + 2).Value = rngU.Cells(I, J).Value '//...VG added
                        For iCol = 1 To 2 '//...VG added
                            rngC.Cells(lChanges, iCol).Font.Color = vbMagenta '//...VG edited
                            rngC.Cells(lChanges, iCol).Font.Bold = True '//...VG edited
                        Next iCol '//...VG adde
                    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
            
                If (J <> rngU.Columns.Count) Then '//...VG added
                    iCol = J + 1 '//...VG added
                Else '//...VG added
                    iCol = J + 2 '//...VG added
                End If '//...VG added
                
                rngC.Cells(lChanges, iCol).Value = rngU.Cells(I, J).Value  '//...VG edited
                rngC.Cells(lChanges, iCol).Font.Color = vbBlue '//...VG edited
                rngC.Cells(lChanges, iCol).Font.Bold = True '//...VG edited

            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
                                  

Open in new window

0
 
FarWestCommented:
do you have a fixed layout of the sheets or you want it generic,
if fixed layout you can put desired values as formula with conditional formatting (for example if B <> F)
if the layout is dynamic and you don't have fixed columns it is better to have it as single row from each sheet and format cells if any have changed or inserted or deleted
like
Row1-Sheet1
Row1-Sheet2
Row2-Sheet1
Row2-Sheet2
 ..etc


btw: I did not recognize that code deal with insertion
0
 
bose3Author Commented:
FarWest,

The columns are static. I would like to see the result (old/new value) in columns, instead of rows as in your example.

Fez
0
Cloud Class® Course: Microsoft Azure 2017

Azure has a changed a lot since it was originally introduce by adding new services and features. Do you know everything you need to about Azure? This course will teach you about the Azure App Service, monitoring and application insights, DevOps, and Team Services.

 
FarWestCommented:
please post a sample sheet with named sheets and named range matching the code
0
 
bose3Author Commented:
FarWest,

See attached.
Comparing-two-spreadsheets.xlsm
0
 
FarWestCommented:
the result  sheet is not matching what you said it is the current result in the image attached with your question!
is this the last version?
0
 
bose3Author Commented:
FarWest/Visio Guy

Thanks for the effort. I was able to write my own code rather than trying to modify what I posted.

Fez
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.