Compare two worksheet ranges
1999-12-20 Worksheets 0 67
With the macro below it is possible to compare the content of two worksheet ranges.
The result is displayed in a new workbook listing all cell differences.
Sub CompareWorksheetRanges(rng1 As Range, rng2 As Range) Dim r As Long, c As Integer Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String Dim rptWB As Workbook, DiffCount As Long If rng1 Is Nothing Or rng2 Is Nothing Then Exit Sub If rng1.Areas.Count > 1 Or rng2.Areas.Count > 1 Then MsgBox "Can't compare multiple selections!", _ vbExclamation, "Compare Worksheet Ranges" Exit Sub End If Application.ScreenUpdating = False Application.StatusBar = "Creating the report..." Set rptWB = Workbooks.Add Application.DisplayAlerts = False While Worksheets.Count > 1 Worksheets(2).Delete Wend Application.DisplayAlerts = True With rng1 lr1 = .Rows.Count lc1 = .Columns.Count End With With rng2 lr2 = .Rows.Count lc2 = .Columns.Count End With maxR = lr1 maxC = lc1 If maxR < lr2 Then maxR = lr2 If maxC < lc2 Then maxC = lc2 If lr1 <> lr2 Or lc1 <> lc2 Then If MsgBox("The two ranges you want to compare are of different size!" & _ Chr(13) & "Do you want to continue anyway?", _ vbQuestion + vbYesNo, "Compare Worksheet Ranges") = vbNo Then Exit Sub End If DiffCount = 0 For c = 1 To maxC Application.StatusBar = "Comparing cells " & _ Format(c / maxC, "0 %") & "..." For r = 1 To maxR cf1 = "" cf2 = "" On Error Resume Next cf1 = rng1.Cells(r, c).FormulaLocal cf2 = rng2.Cells(r, c).FormulaLocal On Error GoTo 0 If cf1 <> cf2 Then DiffCount = DiffCount + 1 Cells(r, c).Formula = "'" & cf1 & " <> " & cf2 End If Next r Next c Application.StatusBar = "Formatting the report..." With Range(Cells(1, 1), Cells(maxR, maxC)) .Interior.ColorIndex = 19 With .Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlHairline End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlHairline End With With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlHairline End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlHairline End With On Error Resume Next With .Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlHairline End With With .Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlHairline End With On Error GoTo 0 End With Columns("A:IV").ColumnWidth = 20 rptWB.Saved = True If DiffCount = 0 Then rptWB.Close False End If Set rptWB = Nothing Application.StatusBar = False Application.ScreenUpdating = True MsgBox DiffCount & " cells contain different formulas!", _ vbInformation, "Compare Worksheet Ranges" End SubThis example macro shows how to use the macro above:
Sub TestCompareWorksheetRanges() ' compare two ranges in the active worksheet in the active workbook CompareWorksheetRanges Range("A1:A100"), Range("B1:B100") ' compare two ranges in two different worksheets in the active workbook CompareWorksheetRanges Worksheets(1).Range("A1:A100"), _ Worksheets(2).Range("B1:B100") ' compare two ranges in two different worksheets in two different workbooks CompareWorksheetRanges ActiveWorkbook.Worksheets(1).Range("A1:A100"), _ Workbooks("WorkBookName.xls").Worksheets(1).Range("B1:B100") End Sub