Sub CompareRows()
Dim Row1 As Range
Dim Row2 As Range
'Prompt user for the first row range to compare...
'----------------------------------------------------
Set Row1 = Application.InputBox("Select First Row to Compare", Type:=8)
'Check that the range they have provided consists of only 1 row...
If Row1.Rows.Count > 1 Then
Do Until Row1.Rows.Count = 1
MsgBox "You can only select 1 row"
Set Row1 = Application.InputBox("Select First Row to Compare", Type:=8)
Loop
End If
'Prompt user for the second row range to compare...
'----------------------------------------------------
Set Row2 = Application.InputBox("Select Second Row to Compare", Type:=8)
'Check that the range they have provided consists of only 1 row...
If Row2.Rows.Count > 1 Then
Do Until Row2.Rows.Count = 1
MsgBox "You can only select 1 row"
Set Row2 = Application.InputBox("Select Second Row to Compare", Type:=8)
Loop
End If
'Check both row ranges are the same size...
'---------------------------------------------
If Row2.Columns.Count <> Row1.Columns.Count Then
Do Until Row2.Columns.Count = Row1.Columns.Count
MsgBox "The second row must be the same size as the first"
Set Row2 = Application.InputBox("Select Second Row to Compare", Type:=8)
Loop
End If
'If entire rows have been selected (e.g. $AEmbarrassedA), limit the range sizes to the
'UsedRange of the active sheet. This stops the routine checking the entire sheet
'unnecessarily.
'-------------------------------------------------------------------------------
If Row1.Columns.Count = 16384 Then
Set Row1 = Range(Row1.Cells(1), Row1.Cells(ActiveSheet.UsedRange.Columns.Count))
Set Row2 = Range(Row2.Cells(1), Row2.Cells(ActiveSheet.UsedRange.Columns.Count))
End If
'Perform the comparison and set cells that are the same to yellow
'----------------------------------------------------------------
Dim intCell As Long
For intCell = 1 To Row1.Columns.Count
If Row1.Cells(intCell) <> Row2.Cells(intCell) Then
Row1.Cells(intCell).Interior.Color = vbYellow
Row2.Cells(intCell).Interior.Color = vbYellow
Else
Row1.Cells(intCell).Interior.Color = vbWhite
Row2.Cells(intCell).Interior.Color = vbWhite
End If
Next
End Sub
Sub CompareRows2(Row1 As Range, Row2 As Range)
Dim intCell As Long
For intCell = 1 To Row1.Columns.Count
On Error Resume Next
If Row1.Cells(intCell) <> Row2.Cells(intCell) Then
' Row1.Cells(intCell).Interior.Color = vbYellow
Row2.Cells(intCell).Interior.Color = vbYellow
Else
' Row1.Cells(intCell).Interior.Color = vbWhite
Row2.Cells(intCell).Interior.Color = vbWhite
End If
Next
End Sub
Sub CheckRowSame()
'
' CheckRowSame Macro
'
Dim Row1 As Range
Dim Row2 As Range
Dim Resource1 As String
Dim Resource2 As String
Dim Columns As Integer
Dim ColumnLetter As String
Application.Goto Range("A2"), True
ActiveCell.Offset(1, 0).Range("A1").Select
Resource1 = ActiveCell.Text
Columns = ActiveSheet.UsedRange.Columns.Count
If Columns = 3 Then ColumnLetter = "C"
If Columns = 4 Then ColumnLetter = "D"
If Columns = 5 Then ColumnLetter = "E"
If Columns = 6 Then ColumnLetter = "F"
If Columns = 7 Then ColumnLetter = "G"
If Columns = 8 Then ColumnLetter = "H"
If Columns = 9 Then ColumnLetter = "I"
If Columns = 10 Then ColumnLetter = "J"
If Columns = 11 Then ColumnLetter = "K"
If Columns = 12 Then ColumnLetter = "L"
If Columns = 13 Then ColumnLetter = "M"
If Columns = 14 Then ColumnLetter = "N"
If Columns = 15 Then ColumnLetter = "O"
If Columns = 16 Then ColumnLetter = "P"
If Columns = 17 Then ColumnLetter = "Q"
If Columns = 18 Then ColumnLetter = "R"
If Columns = 19 Then ColumnLetter = "S"
If Columns = 20 Then ColumnLetter = "T"
If Columns = 21 Then ColumnLetter = "U"
If Columns = 22 Then ColumnLetter = "V"
If Columns = 23 Then ColumnLetter = "W"
If Columns = 24 Then ColumnLetter = "X"
If Columns = 25 Then ColumnLetter = "Y"
If Columns = 26 Then ColumnLetter = "Z"
Do While Resource1 <> ""
Set Row1 = Range("A" & ActiveCell.Row, ColumnLetter & ActiveCell.Row)
' Resource1 = ActiveCell.Text
ActiveCell.Offset(1, 0).Range("A1").Select
Resource2 = ActiveCell.Text
Set Row2 = Range("A" & ActiveCell.Row, ColumnLetter & ActiveCell.Row)
If Resource1 = Resource2 Then
Call CompareRows2(Row1, Row2)
ActiveCell.Offset(1, 0).Range("A1").Select
If Resource1 = ActiveCell.Text Then
ActiveCell.Offset(-1, 0).Range("A1").Select
Else
Resource1 = ActiveCell.Text
End If
Else
ActiveCell.Offset(1, 0).Range("A1").Select
If Resource2 = ActiveCell.Text Then
Resource1 = ActiveCell.Text
ActiveCell.Offset(-1, 0).Range("A1").Select
Else
Resource1 = ActiveCell.Text
End If
End If
Loop
Application.Goto Range("A2"), True
End Sub