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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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
FarWestCommented:
please post a sample sheet with named sheets and named range matching the code
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

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
Chris RothCommented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
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
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.