G
Guest
Dear All,
Firstly, please let me apologise to the author of this piece of code as I am
unaware of its provenance. It is a very useful piece of code that allows me
to compare two sheets and write the differences to a third. Unlike some
comparison solutions I have come across this does not cite the cell reference
where a discrepancy occurs but actually recalls the data element that is
different and highlights it within the context of the row that it sits and
with a background colour. This is incredibly useful but unfortunately it is
case sensitive. Is there some insertion to the code below that would force
it to ignore case?
Sub LookForDiscrepancies()
Dim varS1, varS2, varH1, varH2
Dim rngS1 As Range, rngS2 As Range
Dim c As Range, c1 As Range, c2 As Range
Dim iRow As Integer, iCol As Integer, i As Integer, iTest As Integer
Application.ScreenUpdating = False
Sheet1.Activate
Set rngS1 = Intersect(Sheet1.UsedRange, Columns("A"))
Sheet2.Activate
Set rngS2 = Intersect(Sheet2.UsedRange, Columns("A"))
Sheet3.Activate
Sheet3.Cells.Select
Selection.Delete Shift:=xlUp
Sheet3.Rows("1:1").Value = Sheet1.Rows("1:1").Value
Let iRow = iRow + 2
With rngS2
'Search for Sheet1 IDs on Sheet2
For Each c1 In rngS1
On Error GoTo 0
Set c = .Find(what:=c1.Value) 'Look for match
If c Is Nothing Then 'Copy rows to Sheet3
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) = 1
Next i
Let iTest = 0
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet1.UsedRange, c1.EntireRow)
Let varS2 = Intersect(Sheet2.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet1.UsedRange, c1.EntireRow).Count
ReDim varH1(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH1(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 20
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With
Let iRow = iRow + 0
Range("A1").Offset(iRow, 0).Value = "Sheet2 vs Sheet1"
Let iRow = iRow + 2
With rngS1
'Search for Sheet2 IDs on Sheet1
For Each c2 In rngS2
On Error GoTo 0
Set c = .Find(what:=c2.Value) 'Look for match
If c Is Nothing Then 'Copy rows to Sheet3
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) = 1
Next i
Let iTest = 0
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet2.UsedRange, c2.EntireRow)
Let varS2 = Intersect(Sheet1.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet2.UsedRange, c2.EntireRow).Count
ReDim varH2(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH2(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH2(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 3
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With
Sheet3.Select 'resize the columns
Range("A:Z").Columns.AutoFit
Range("A1").Select
End Sub
As always I am grateful for any assistance.
Thanks
Firstly, please let me apologise to the author of this piece of code as I am
unaware of its provenance. It is a very useful piece of code that allows me
to compare two sheets and write the differences to a third. Unlike some
comparison solutions I have come across this does not cite the cell reference
where a discrepancy occurs but actually recalls the data element that is
different and highlights it within the context of the row that it sits and
with a background colour. This is incredibly useful but unfortunately it is
case sensitive. Is there some insertion to the code below that would force
it to ignore case?
Sub LookForDiscrepancies()
Dim varS1, varS2, varH1, varH2
Dim rngS1 As Range, rngS2 As Range
Dim c As Range, c1 As Range, c2 As Range
Dim iRow As Integer, iCol As Integer, i As Integer, iTest As Integer
Application.ScreenUpdating = False
Sheet1.Activate
Set rngS1 = Intersect(Sheet1.UsedRange, Columns("A"))
Sheet2.Activate
Set rngS2 = Intersect(Sheet2.UsedRange, Columns("A"))
Sheet3.Activate
Sheet3.Cells.Select
Selection.Delete Shift:=xlUp
Sheet3.Rows("1:1").Value = Sheet1.Rows("1:1").Value
Let iRow = iRow + 2
With rngS2
'Search for Sheet1 IDs on Sheet2
For Each c1 In rngS1
On Error GoTo 0
Set c = .Find(what:=c1.Value) 'Look for match
If c Is Nothing Then 'Copy rows to Sheet3
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) = 1
Next i
Let iTest = 0
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet1.UsedRange, c1.EntireRow)
Let varS2 = Intersect(Sheet2.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet1.UsedRange, c1.EntireRow).Count
ReDim varH1(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH1(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 20
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With
Let iRow = iRow + 0
Range("A1").Offset(iRow, 0).Value = "Sheet2 vs Sheet1"
Let iRow = iRow + 2
With rngS1
'Search for Sheet2 IDs on Sheet1
For Each c2 In rngS2
On Error GoTo 0
Set c = .Find(what:=c2.Value) 'Look for match
If c Is Nothing Then 'Copy rows to Sheet3
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) = 1
Next i
Let iTest = 0
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet2.UsedRange, c2.EntireRow)
Let varS2 = Intersect(Sheet1.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet2.UsedRange, c2.EntireRow).Count
ReDim varH2(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH2(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH2(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 3
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With
Sheet3.Select 'resize the columns
Range("A:Z").Columns.AutoFit
Range("A1").Select
End Sub
As always I am grateful for any assistance.
Thanks