Compare Two Sheet for Changes and Highlighted them

bilal604

New Member
Joined
Apr 10, 2018
Messages
1
Hi,
I have two sheets, one is old and 2nd is a new version after some changes.
I want to compare both sheets and want to highlight changes also if i can get old value and new values as well.

could anyone help me please here . i dont prefer any 3rd party paid tool BTW.
 

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

iliace

Well-known Member
Joined
Jan 15, 2008
Messages
3,543
Office Version
  1. 365
  2. 2016
  3. 2010
Platform
  1. Windows
I have put together a tool in the past (which I can share), but there are limitations for this kind of analysis.
1. What happens when new rows are inserted/deleted?
2. What happens when new columns are inserted/deleted?
3. What happens when sheets are renamed?
4. What happens when sheets are inserted/deleted?

I have used this code in the past, but please use on a copy of your workbook as it has not been tested recently.

CompareWorkbooks() is the entry point procedure in the example below.
Code:
' begin code
Dim wkbLog As Excel.Workbook
Dim iLogPos1 As Long, iLogPos2 As Long, iLogPos3 As Long, iLogPos4 As Long, iLogPos5 As Long
Private Sub LogSheetChange(s As String)
  iLogPos1 = iLogPos1 + 1
  wkbLog.Worksheets(1).Cells(iLogPos1, 1).Value = s
End Sub
Private Sub LogRowChange(s As String)
  iLogPos2 = iLogPos2 + 1
  wkbLog.Worksheets(2).Cells(iLogPos2, 1).Value = s
End Sub
Private Sub logValueChange(sSheet As String, sRange As String, sVal1 As String, sVal2 As String)
  iLogPos3 = iLogPos3 + 1
  With wkbLog.Worksheets(3)
    .Cells(iLogPos3, 1).Value = sSheet
    .Cells(iLogPos3, 2).Value = sRange
    .Cells(iLogPos3, 3).Value = sVal1
    .Cells(iLogPos3, 4).Value = sVal2
  End With
End Sub
Private Sub logFormulaChange(sSheet As String, sRange As String, sVal1 As String, sVal2 As String)
  iLogPos4 = iLogPos4 + 1
  With wkbLog.Worksheets(4)
    .Cells(iLogPos4, 1).Value = sSheet
    .Cells(iLogPos4, 2).Value = sRange
    .Cells(iLogPos4, 3).Value = "'" & sVal1
    .Cells(iLogPos4, 4).Value = "'" & sVal2
  End With
End Sub
Public Sub logError(sSheet As String, sRange As String, sVal1 As String, sVal2 As String, sProblem As String)
  iLogPos5 = iLogPos5 + 1
  With wkbLog.Worksheets(5)
    .Cells(iLogPos5, 1).Value = sSheet
    .Cells(iLogPos5, 2).Value = sRange
    .Cells(iLogPos5, 3).Value = "'" & sVal1
    .Cells(iLogPos5, 4).Value = "'" & sVal2
    .Cells(iLogPos5, 5).Value = sProblem
  End With
End Sub
Public Sub CompareWorkbooks()
  Dim sPath1 As String
  Dim sPath2 As String
  
  With Application.FileDialog(msoFileDialogOpen)
    .AllowMultiSelect = False
    .Title = "Select Original File"
    If .Show Then
      sPath1 = .SelectedItems(1)
    Else
      Exit Sub
    End If
    
    .Title = "Select File to Compare"
    If .Show Then
      sPath2 = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With
  
  iLogPos1 = 1
  iLogPos2 = 1
  iLogPos3 = 1
  iLogPos4 = 1
  iLogPos5 = 1
  
  If Not doCompare(sPath1, sPath2) Then
    Call MsgBox("An error occurred = exiting.", vbOKOnly + vbCritical)
  End If
End Sub
Private Function doCompare(sPath1 As String, sPath2 As String) As Boolean
  Dim wkb1 As Excel.Workbook
  Dim wkb2 As Excel.Workbook
  
  Dim calcs As Excel.XlCalculation
  On Error Resume Next
    Set wkb1 = Application.Workbooks.Open(sPath1, ReadOnly:=False, UpdateLinks:=False)
  On Error GoTo 0
  If wkb1 Is Nothing Then
    doCompare = False
    Call MsgBox("Could not open " & sPath1, vbOKOnly + vbExclamation)
    Exit Function
  End If
  
  On Error Resume Next
    Set wkb2 = Application.Workbooks.Open(sPath2, ReadOnly:=True, UpdateLinks:=False)
  On Error GoTo 0
  If wkb2 Is Nothing Then
    doCompare = False
    Call MsgBox("Could not open " & sPath2, vbOKOnly + vbExclamation)
    Exit Function
  End If
  
  Set wkbLog = Application.Workbooks.Add
  Dim i As Long
  For i = 1 To 5 - wkbLog.Worksheets.Count
    wkbLog.Worksheets.Add
  Next i
  
  wkbLog.Worksheets(1).Name = "Sheet Changes"
  wkbLog.Worksheets(2).Name = "Range Changes"
  wkbLog.Worksheets(3).Name = "Value Changes"
  wkbLog.Worksheets(4).Name = "Formula Changes"
  wkbLog.Worksheets(5).Name = "Formula Errors"
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  calcs = Application.Calculation
  Application.Calculation = xlCalculationManual
  
  CheckSheets wkb1, wkb2
  
  wkbLog.SaveAs Filename:=wkb1.Name & " comparison log " & Format(Now(), "yyyy-mm-dd") & ".xlsx", FileFormat:=xlWorkbookNormal
  'wkb1.SaveAs Filename:="Comparison of " & wkb1.Name
  wkb1.Close False
  wkb2.Close False
  
  Application.StatusBar = False
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.Calculation = calcs
  
  doCompare = True
End Function
Private Function CheckSheets(ByRef wkb1 As Excel.Workbook, ByRef wkb2 As Excel.Workbook) As Boolean
  Dim wsh1 As Excel.Worksheet, wsh2 As Excel.Worksheet
  Dim bFound As Boolean
  Application.StatusBar = "Checking Worksheets"
  
  LogSheetChange ""
  LogSheetChange "Checking worksheets in " & wkb1.Name & " against " & wkb2.Name
  
  ' check missing wsh2
  For Each wsh1 In wkb1.Worksheets
    Set wsh2 = Nothing
    Application.StatusBar = "Checking Worksheets - " & wsh1.Name
    On Error Resume Next
      Set wsh2 = wkb2.Worksheets(wsh1.Name)
    On Error GoTo 0
    
    If wsh2 Is Nothing Then
      LogSheetChange wsh1.Name & " NOT FOUND in " & wkb2.Name
    Else
      LogRowChange ""
      LogRowChange "Checking ranges in " & wsh1.Name
      CheckRanges wsh1, wsh2
    End If
  Next wsh1
  
  LogSheetChange ""
  LogSheetChange "Checking for additional worksheets in " & wkb2.Name _
                  & " that are not in " & wkb1.Name
  
  ' check additional wsh1
  For Each wsh2 In wkb2.Worksheets
    bFound = False
    Application.StatusBar = "Checking Worksheets - " & wsh2.Name
    For Each wsh1 In wkb1.Worksheets
      If StrComp(wsh2.Name, wsh1.Name) = 0 Then
        bFound = True
        Exit For
      End If
    Next wsh1
    
    If Not bFound Then
      LogSheetChange wsh2.Name & " has been added in " & wkb2.Name
    End If
  Next wsh2
  
  CheckSheets = True
End Function
Private Function CheckRanges(ByRef wsh1 As Excel.Worksheet, ByRef wsh2 As Excel.Worksheet) As Boolean
  Dim i1 As Long, i2 As Long
  Dim iRows As Long, iCols As Long
  
  LogRowChange ""
  LogRowChange "Checking " & wsh1.Name & " rows and columns"
  
  i1 = wsh1.UsedRange.Rows.Count
  i2 = wsh2.UsedRange.Rows.Count
  
  If i1 <> i2 Then
    LogRowChange wsh1.Name & " in " & wsh1.Parent.Name & " has " & _
        IIf(i1 < i2, " fewer ", " more ") & " rows than " & wsh2.Name & " in " & wsh2.Parent.Name
  Else
    LogRowChange wsh1.Name & " rows match"
  End If
  
  iRows = Application.WorksheetFunction.Max(i1, i2)
  i1 = wsh1.UsedRange.Columns.Count
  i2 = wsh2.UsedRange.Columns.Count
  
  If i1 <> i2 Then
    LogRowChange wsh1.Name & " in " & wsh1.Parent.Name & " has " & _
        IIf(i1 < i2, " fewer ", " more ") & " columns than " & wsh2.Name & " in " & wsh2.Parent.Name
  Else
    LogRowChange wsh1.Name & " columns match"
  End If
  
  iCols = Application.WorksheetFunction.Max(i1, i2)
  
  CheckData wsh1, wsh2, iRows, iCols
  CheckRanges = True
End Function
Private Function CheckData(ByRef wsh1 As Excel.Worksheet, ByRef wsh2 As Excel.Worksheet, iRows As Long, iCols As Long) As Boolean
  Dim r1 As Excel.Range, r2 As Excel.Range
  Dim i As Long, j As Long
  
  logValueChange "", "", "", ""
  logValueChange wsh1.Name, "A1:" & wsh1.Cells(iRows, iCols).Address(False, False), wsh1.Parent.Name, wsh2.Parent.Name
  
  logFormulaChange "", "", "", ""
  logFormulaChange wsh1.Name, "A1:" & wsh1.Cells(iRows, iCols).Address(False, False), wsh1.Parent.Name, wsh2.Parent.Name
  
  logError "", "", "", "", ""
  logError wsh1.Name, "A1:" & wsh1.Cells(iRows, iCols).Address(False, False), wsh1.Parent.Name, wsh2.Parent.Name, ""
  For i = 1 To iRows
    For j = 1 To iCols
      Set r1 = wsh1.Cells(i, j)
      Set r2 = wsh2.Cells(i, j)
      If r1.HasFormula And r2.HasFormula Then
        If Not IsError(r1.Value) And Not IsError(r2.Value) Then
         On Error Resume Next
         If StrComp(r1.Formula, r2.Formula) <> 0 Then
         
            logFormulaChange wsh1.Name, r1.Address, r1.Formula, r2.Formula
'            With r1.Interior
'              .Pattern = xlSolid
'              .PatternColorIndex = xlAutomatic
'              .Color = 65535
'            End With
          End If ' string compare
          On Error GoTo 0
        Else ' is error
          logError wsh1.Name, r1.Address & " ERROR", r1.Formula, r2.Formula, r2.Text
        End If
      End If
      On Error Resume Next:
        If Len(r1.Value) > 0 Or Len(r2.Value) > 0 Then
          If IsNumeric(r1.Value) And IsNumeric(r2.Value) Then
            If r1.Value <> r2.Value Then
              logValueChange wsh1.Name, r1.Address, "=" & r1.Address(True, True, xlA1, True), "=" & r2.Address(True, True, xlA1, True)
'              With r1.Interior
'                .Pattern = xlSolid
'                .PatternColorIndex = xlAutomatic
'                .Color = 65535
'              End With
            End If ' number compare
          Else ' not isnumeric
            If StrComp(r1.Value, r2.Value) <> 0 Then
              logValueChange wsh1.Name, r1.Address, "=" & r1.Address(True, True, xlA1, True), "=" & r2.Address(True, True, xlA1, True)
'              With r1.Interior
'                .Pattern = xlSolid
'                .PatternColorIndex = xlAutomatic
'                .Color = 65535
'              End With
            End If ' string compare
          End If ' numeric or string
        End If
      On Error GoTo 0
    Next j
  Next i
End Function
<strike></strike>
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,108,728
Messages
5,524,486
Members
409,584
Latest member
RedHelp

This Week's Hot Topics

Top