Macro for comparing two sheets and highlight differences

Question

Macro for comparing two sheets and highlight differences

Anonymous

Hello,

I have a code for comparing two sheets and highlight differences, this code works fine.

But i'm facing issue when a whole cell or row is deleted in sheet2 with sheet1(original data), each cells shifts up/down and i get huge differences in color.

I want the deleted row/cell to be highlighted as color or pop-up message without effecting other cells which will be compared which avoids shifting the cells too.

Appreciate if anyone could help!

Below is the code which i have now:

Sub RunCompare()

Call compareSheets("Sheet1", "Sheet2")

End Sub

Sub compareSheets(shtSheet1 As String, shtSheet2 As String)

Dim mycell As Range

Dim mydiffs As Integer

'For each cell in sheet2 that is not the same in Sheet1, color it yellow

For Each mycell In ActiveWorkbook.Worksheets(shtSheet2).UsedRange

If Not mycell.Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.row, mycell.Column).Value Then

mycell.Interior.Color = vbYellow

mydiffs = mydiffs + 1

End If

MsgBox mydiffs & " differences found", vbInformation

ActiveWorkbook.Sheets(shtSheet2).Select

End Sub

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

1 answer

Answer 1

Make a new file
Copy the code below into a regular module
Execute Sub Example_CompareData() and study the results

After that have a look into sub Test, modified it for your needs and run it on your original data.

Andreas.

Option Explicit

Sub Example_CompareData()

Dim i As Integer, j As Integer

Dim Equal(1 To 2) As Range

Dim Missing(1 To 2) As Range

If MsgBox("This example erases all data in the active sheet! Continue?", _

vbOKCancel + vbDefaultButton2, "Example_CompareData") = vbCancel Then Exit Sub

'Create some example data

Cells.Clear

For i = 0 To 5 Step 5

Range("A1").Offset(0, i).Resize(1, 4) = _

Array("Nr", "HeaderA", "HeaderB", "HeaderC")

For j = 1 To 25 'Increase this number for more rows

Range("A1").Offset(j, i).Resize(1, 4) = _

Array(j, Int(10 * Rnd), Int(10 * Rnd), Int(10 * Rnd))

MsgBox "This is the basic data, now I compare the columns HeaderA & HeaderC"

'Compare the columns which heading is "HeaderA" and "HeaderC"

CompareData _

Intersect(Range("A:D"), ActiveSheet.UsedRange), Array("HeaderA", "HeaderC"), _

Intersect(Range("F:I"), ActiveSheet.UsedRange), Array("HeaderA", "HeaderC"), _

Equal(1), Equal(2), Missing(1), Missing(2), xlYes

'Color the results: blue = equal data, red = missing data

For i = 1 To 2

If Not Equal(i) Is Nothing Then Equal(i).Font.Color = vbBlue

If Not Missing(i) Is Nothing Then Missing(i).Font.Color = vbRed

Range("A1:D1").Copy Range("K1")

Equal(1).Copy Range("K2")

'Copy the missing data from first range to column P

Range("A1:D1").Copy Range("P1")

Missing(1).Copy Range("P2")

End Sub

Sub Test()

Dim R(1 To 2) As Range

Dim Equal(1 To 2) As Range

Dim Missing(1 To 2) As Range

Dim i As Integer

'Setup the cells to compare

Set R(1) = Sheets(1).Range("A1").CurrentRegion

Set R(2) = Sheets(2).Range("A1").CurrentRegion

'Compare the cells by column A

CompareData R(1), 1, R(2), 1, Equal(1), Equal(2), Missing(1), Missing(2), xlNo

'Color the missing cells

For i = 1 To 2

If Not Missing(i) Is Nothing Then

Missing(i).Interior.Color = vbYellow

End If

Sub CompareData( _

ByVal R1 As Range, ByVal ID1, _

ByVal R2 As Range, ByVal ID2, _

Optional ByRef Equal1 As Range, Optional ByRef Equal2 As Range, _

Optional ByRef Missing1 As Range, Optional ByRef Missing2 As Range, _

Optional ByVal Header As XlYesNoGuess = xlNo, _

Optional ByVal Compare As VbCompareMethod = vbBinaryCompare)

'Compares R1 with R2 by rows

' ID could be a single value or an array of values with:

' a column number: 1 to Columns.Count of R1 or R2

' a column name: "A" to "IV" resp. "XFD" in XL2007 and above

' if Header = xlYes then

' a heading: must be somewhere in the first row

' Returns ranges with all equal and missing cells

Const ErrNum = 1000

Dim Dict(1 To 2) As Object 'Scripting.Dictionary

Dim Data As Variant

Dim Index() As Long

Dim ThisR As Range, ThisE As Range, ThisM As Range, TempR As Range

Dim ThisID As Variant, Temp As Variant

Dim i As Integer, j As Integer

Dim rw As Long, cl As Long

Dim Key As String

If Header = xlGuess Then

Err.Raise ErrNum, "CompareData", "Header=xlGuess is not supported"

End If

'Step 1: Initialize

For i = 1 To 2

'Get the appropriate variables

If i = 1 Then

Set ThisR = R1

ThisID = ID1

If Not IsArray(ThisID) Then

ReDim ThisID(0 To 0)

ThisID(0) = ID1

End If

Else

Set ThisR = R2

ThisID = ID2

If Not IsArray(ThisID) Then

ReDim ThisID(0 To 0)

ThisID(0) = ID2

End If

If ThisR Is Nothing Then

Err.Raise ErrNum, "CompareData", "R" & i & " is nothing"

End If

If IsMissing(ThisID(LBound(ThisID))) Then

Err.Raise ErrNum, "CompareData", "ID" & i & " is missing"

End If

'Read in all data

Data = ThisR.Value2

If Not IsArray(Data) Then

ReDim Data(1 To 1, 1 To 1)

Data(1, 1) = ThisR.Value2

End If

If Header = xlYes And UBound(Data) < 2 Then

Err.Raise ErrNum, "CompareData", "R" & i & ": not enough rows"

End If

'Create the dictionary

Set Dict(i) = CreateObject("Scripting.Dictionary")

If Compare = vbTextCompare Then Dict(i).CompareMode = vbTextCompare

ReDim Index(LBound(ThisID) To UBound(ThisID))

If Header = xlYes Then

'Parse the header

For j = LBound(ThisID) To UBound(ThisID)

For cl = 1 To UBound(Data, 2)

If StrComp(ThisID(j), CStr(Data(1, cl)), Compare) = 0 Then

Index(j) = cl

Exit For

End If

Err.Raise ErrNum, "CompareData", _

"ID" & i & ": Header " & ThisID(j) & " not found"

End If

'Parse the columns

On Error Resume Next

For j = LBound(ThisID) To UBound(ThisID)

If IsNumeric(ThisID(j)) Then

Index(j) = ThisID(j)

Else

Set TempR = Intersect(ThisR.Parent.Columns(ThisID(j)), ThisR)

If Not TempR Is Nothing Then

Index(j) = TempR.Column - ThisR.Column + 1

End If

If Index(j) < 1 Or Index(j) > UBound(Data, 2) Then

On Error GoTo 0

Err.Raise ErrNum, "CompareData", _

"ID" & i & ": Column " & ThisID(j) & " not inside R" & i

End If

'Create the dictionary from the data

For rw = IIf(Header = xlYes, 2, 1) To UBound(Data)

Key = CStr(Data(rw, Index(LBound(ThisID))))

For j = LBound(ThisID) + 1 To UBound(ThisID)

Key = Key & vbNullChar & CStr(Data(rw, Index(j)))

If Not Dict(i).Exists(Key) Then

Dict(i).Add Key, Array(rw)

Else

Temp = Dict(i)(Key)

ReDim Preserve Temp(LBound(Temp) To UBound(Temp) + 1)

Temp(UBound(Temp)) = rw

Dict(i)(Key) = Temp

End If

'Step 2: Compare the dictionaries and build the results

For i = 1 To 2

j = i Mod 2 + 1

'Get the appropriate variables

If i = 1 Then

Set ThisR = R1

Set ThisE = Equal1

Set ThisM = Missing1

Else

Set ThisR = R2

Set ThisE = Equal2

Set ThisM = Missing2

End If

'Get the keys and search them in the other dictionary

Data = Dict(i).Keys

For rw = LBound(Data) To UBound(Data)

Key = Data(rw)

Temp = Dict(i)(Key)

If Dict(j).Exists(Key) Then

For cl = LBound(Temp) To UBound(Temp)

If ThisE Is Nothing Then

Set ThisE = ThisR.Rows(Temp(cl))

Else

Set ThisE = Union(ThisE, ThisR.Rows(Temp(cl)))

End If

For cl = LBound(Temp) To UBound(Temp)

If ThisM Is Nothing Then

Set ThisM = ThisR.Rows(Temp(cl))

Else

Set ThisM = Union(ThisM, ThisR.Rows(Temp(cl)))

End If

If i = 1 Then

Set R1 = ThisR

Set Equal1 = ThisE

Set Missing1 = ThisM

Else

Set R2 = ThisR

Set Equal2 = ThisE

Set Missing2 = ThisM

End If

Share via

Macro for comparing two sheets and highlight differences

1 answer