Code:
Option Explicit
Sub GoGreen() ' http://www.excelfox.com/forum/showthread.php/2278-Compare-each-complete-row-of-sheet2-with-sheet3-each-complete-row
Rem 1 Worksheets info and data ranges
Dim Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet
Set Ws2 = ThisWorkbook.Worksheets("Sheet2"): Set Ws3 = ThisWorkbook.Worksheets("Sheet3"): Set Ws4 = ThisWorkbook.Worksheets("Sheet4")
'1b last rows and columns using Range.Find Method : https://msdn.microsoft.com/de-de/vba/excel-vba/articles/range-find-method-excel
Dim Lr2 As Long, Lr3 As Long, Lc2 As Long, Lc3 As Long
Let Lr2 = Ws2.Cells.Find(What:="*", After:=Ws2.Range("A" & Rows.Count & ""), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=True).Row
Let Lr3 = Ws3.Cells.Find(What:="*", After:=Ws3.Range("A" & Rows.Count & ""), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=True).Row
Let Lc2 = Ws2.Cells.Find(What:="*", After:=Ws2.Cells.Item(1, Columns.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=True).Column
Let Lc3 = Ws3.Cells.Find(What:="*", After:=Ws3.Cells.Item(1, Columns.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=True).Column
'1b(ii) determin maximum column used in either data Worksheets
Dim Lc As Long: Let Lc = Lc2: If Lc3 > Lc2 Then Let Lc = Lc3
'1c data ranges
Dim Rng2 As Range, Rng3 As Range
Set Rng2 = Application.Range(Ws2.Range("A1"), Ws2.Cells.Item(Lr2, Lc)): Set Rng3 = Application.Range(Ws3.Range("A1"), Ws3.Cells.Item(Lr3, Lc))
Rem 2 Build arrays for checking strings of complete row data
Dim arrSht2Chk() As String, arrSht3Chk() As String
ReDim arrSht2Chk(1 To Lr2): ReDim arrSht3Chk(1 To Lr3)
Dim Cnt As Long
'2a arrSht2Chk()
For Cnt = 1 To UBound(arrSht2Chk())
Dim RngTmp As Range
Set RngTmp = Application.Index(Rng2, Cnt, 0) ' range array 1 breadthJPG : https://imgur.com/IJgKBi3
Dim StrTmp As String, Clms As Long
For Clms = 1 To Lc
Let StrTmp = StrTmp & RngTmp.Item(Clms)
Next Clms
Let arrSht2Chk(Cnt) = StrTmp
Let StrTmp = ""
Next Cnt
'2b arrSht3Chk()
For Cnt = 1 To UBound(arrSht3Chk())
Set RngTmp = Application.Index(Rng3, Cnt, 0) '
For Clms = 1 To Lc
Let StrTmp = StrTmp & RngTmp.Item(Clms)
Next Clms
Let arrSht3Chk(Cnt) = StrTmp
Let StrTmp = ""
Next Cnt
Rem 3 Main Loop to check for match and colour column B in Worksheet Sheet4
For Cnt = 1 To UBound(arrSht2Chk())
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht2Chk(Cnt), arrSht3Chk(), 0)
If Not IsError(MtchRes) Then
Let Ws4.Range("B" & Cnt & "").Interior.Color = 5287936
Else
End If
Next Cnt
End Sub
Reply With Quote
Bookmarks