Option Explicit
Sub CompareSheets()
Dim wsTAB As Worksheet
Dim wsSTN As Worksheet
Dim ws3 As Worksheet
Dim lngRow As Long
Dim lngLastRow1 As Long
Dim lngLastRow2 As Long
Dim lngNextRow As Long
Dim colTAB As Collection
Dim colSTN As Collection
Dim lngTAB As Long
Dim lngSTN As Long
Dim lngNR3 As Long
Dim rngFound As Range
Dim strParts() As String
Dim rng As Range
Dim lngArea As Long
Dim lngCell As Long
Const COL_CONCAT = "X"
Set wsTAB = ThisWorkbook.Worksheets("TAB")
Set wsSTN = ThisWorkbook.Worksheets("STN")
Set ws3 = ThisWorkbook.Worksheets("Sheet3")
ws3.UsedRange.Cells.ClearContents
With wsTAB
Application.ScreenUpdating = False
'Insert a blank row at the top of each for filtering purposes
.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
wsSTN.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
lngNextRow = 1
lngLastRow1 = .Cells(Rows.Count, 1).End(xlUp).Row
For lngRow = 2 To lngLastRow1
lngNextRow = lngNextRow + 1
.Cells(lngNextRow, COL_CONCAT) = Join(.Range("A" & lngRow & ":D" & lngRow))
Next
' Do the same for the STN sheet
lngLastRow2 = wsSTN.Cells(Rows.Count, 1).End(xlUp).Row
lngNextRow = 1
For lngRow = 2 To lngLastRow2
lngNextRow = lngNextRow + 1
wsSTN.Cells(lngNextRow, COL_CONCAT) = Join(wsSTN.Range("A" & lngRow & ":D" & lngRow))
Next
' Create a collection of unique concatenated values
Set colTAB = New Collection
For lngRow = 2 To lngLastRow1
On Error Resume Next
colTAB.Add .Cells(lngRow, COL_CONCAT), CStr(.Cells(lngRow, COL_CONCAT))
On Error GoTo 0
Next
' And the same for STN
Set colSTN = New Collection
For lngRow = 2 To lngLastRow2
On Error Resume Next
colSTN.Add wsSTN.Cells(lngRow, COL_CONCAT), CStr(wsSTN.Cells(lngRow, COL_CONCAT))
On Error GoTo 0
Next
' Find duplicates by filtering both tabs and comparing the two counts
' of visible rows
For lngTAB = 1 To colTAB.Count
' Clear any previous autofiltering
On Error Resume Next
.ShowAllData
On Error GoTo 0
.Range(.Cells(1, COL_CONCAT), .Cells(lngLastRow1, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colTAB(lngTAB)
On Error Resume Next
wsSTN.ShowAllData
On Error GoTo 0
wsSTN.Range(wsSTN.Cells(1, COL_CONCAT), wsSTN.Cells(lngLastRow2, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colTAB(lngTAB)
Select Case True
Case .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count < _
wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
' STN count is greater so it's a duplicate
lngNR3 = lngNR3 + 1
strParts = Split(colTAB(lngTAB), "|")
With ws3
.Cells(lngNR3, "A") = strParts(0)
.Cells(lngNR3, "B") = strParts(1)
.Cells(lngNR3, "C") = strParts(2)
.Cells(lngNR3, "D") = strParts(3)
.Cells(lngNR3, "E") = "DUPLICATED"
End With
End Select
' Find Nissing
' Find those in TAB that aren't in STN
Set rng = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
' If Left(colTAB(lngTAB), 4) = "9755" Then
' Stop
' End If
For lngArea = 1 To rng.Areas.Count
For lngCell = 1 To rng.Areas(lngArea).Cells.Count
If Not IsEmpty(rng.Areas(lngArea).Cells(lngCell).Value) Then
Set rngFound = wsSTN.Columns(COL_CONCAT).Find(What:=rng.Areas(lngArea).SpecialCells(xlCellTypeVisible).Cells(lngCell).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
' A count of 1 indicates that only the first row (which is blank) is visible
strParts = Split(rng.Areas(lngArea).Cells(lngCell).Value, "|")
lngNR3 = lngNR3 + 1
With ws3
.Cells(lngNR3, "A") = strParts(0)
.Cells(lngNR3, "B") = strParts(1)
.Cells(lngNR3, "C") = strParts(2)
.Cells(lngNR3, "D") = strParts(3)
.Cells(lngNR3, "E") = "MISSING FROM STN"
End With
End If
End If
Next
Next
Next
' Finally, find those in STN that aren't in TAB
For lngSTN = 1 To colSTN.Count
' Clear any previous autofiltering
On Error Resume Next
wsSTN.ShowAllData
On Error GoTo 0
wsSTN.Range(wsSTN.Cells(1, COL_CONCAT), wsSTN.Cells(lngLastRow1, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colSTN(lngSTN)
On Error Resume Next
.ShowAllData
On Error GoTo 0
.Range(.Cells(1, COL_CONCAT), .Cells(lngLastRow2, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colSTN(lngSTN)
Set rng = wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
For lngArea = 1 To rng.Areas.Count
For lngCell = 1 To rng.Areas(lngArea).Cells.Count
If Not IsEmpty(rng.Areas(lngArea).Cells(lngCell).Value) Then
Set rngFound = .Columns(COL_CONCAT).Find(What:=rng.Areas(lngArea).SpecialCells(xlCellTypeVisible).Cells(lngCell).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
' A count of 1 indicates that only the first row (which is blank) is visible
strParts = Split(rng.Areas(lngArea).Cells(lngCell).Value, "|")
lngNR3 = lngNR3 + 1
With ws3
.Cells(lngNR3, "A") = strParts(0)
.Cells(lngNR3, "B") = strParts(1)
.Cells(lngNR3, "C") = strParts(2)
.Cells(lngNR3, "D") = strParts(3)
.Cells(lngNR3, "E") = "MISSING FROM TAB"
End With
End If
End If
Next
Next
Next
.Columns(COL_CONCAT).AutoFilter
wsSTN.Columns(COL_CONCAT).AutoFilter
ws3.Activate
' Clean up
.Cells(1, "A").EntireRow.Delete
wsSTN.Cells(1, "A").EntireRow.Delete
.Columns(COL_CONCAT).Cells.ClearContents
wsSTN.Columns(COL_CONCAT).Cells.ClearContents
Set colSTN = Nothing
Set colTAB = Nothing
Set wsTAB = Nothing
Set wsSTN = Nothing
Set ws3 = Nothing
Application.ScreenUpdating = True
End With
End Sub
Public Function Join(rng As Range) As String
Dim cel As Range
For Each cel In rng
Join = Join & cel.Text & "|"
Next cel
' remove the last delimiter
Join = Left(Join, Len(Join) - Len("|"))
If Len(Join) < 8 Then
MsgBox "Invalid data found at row " & rng.Row & " in worksheet " & rng.Worksheet.Name
Exit Function
End If
End Function
