Multi-Sheet Lookup & Comparison

' Multi-Sheet Lookup & Comparison
' Compare and match data across multiple worksheets with conditions

Sub MultiSheetComparison()
    ' Main procedure to compare data across sheets
    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("WS1")
    Set ws2 = ThisWorkbook.Sheets("WS2")
    Set ws3 = ThisWorkbook.Sheets("WS3")
    Set ws4 = ThisWorkbook.Sheets("WS4")

    ' Clear previous results in WS4
    ws4.Range("A2:K" & ws4.Cells(ws4.Rows.Count, "A").End(xlUp).Row).ClearContents

    Dim lastRow1 As Long
    lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row

    Dim i As Long
    Dim outputRow As Long
    outputRow = 2

    ' Loop through each row in WS1
    For i = 2 To lastRow1
        Dim valueWS1B As Variant
        valueWS1B = ws1.Cells(i, 2).Value ' Column B

        ' Find matching rows in WS2 (Column A matches WS1 Column B)
        Dim matchRows As Collection
        Set matchRows = FindMatches(ws2, valueWS1B, 1) ' Search WS2 Column A

        If matchRows.Count > 0 Then
            ' For each match in WS2, compare with WS3
            Dim match As Variant
            For Each match In matchRows
                Dim matchRow2 As Long
                matchRow2 = CLng(match)

                Dim valueWS2B As Variant
                valueWS2B = ws2.Cells(matchRow2, 2).Value ' WS2 Column B

                ' Find matches in WS3 Column G
                Dim matchRows3 As Collection
                Set matchRows3 = FindMatches(ws3, valueWS2B, 7) ' Search WS3 Column G

                If matchRows3.Count > 0 Then
                    ' For each match in WS3, apply conditions
                    Dim match3 As Variant
                    For Each match3 In matchRows3
                        Dim matchRow3 As Long
                        matchRow3 = CLng(match3)

                        ' Check conditions
                        Dim columnJ As String
                        Dim columnS As String
                        Dim columnV As String

                        columnJ = CStr(ws3.Cells(matchRow3, 10).Value) ' Column J
                        columnS = CStr(ws3.Cells(matchRow3, 19).Value) ' Column S
                        columnV = CStr(ws3.Cells(matchRow3, 22).Value) ' Column V

                        ' Condition 1: Check if Column J starts with "9"
                        If Left(columnJ, 1) = "9" Then
                            GoTo NextMatch ' Skip this match
                        End If

                        ' Condition 2: Check if Column S is blank
                        If columnS = "" Then
                            GoTo NextMatch ' Skip this match
                        End If

                        ' Condition 3: Check if Column V equals "Cancelled"
                        If columnV = "Cancelled" Then
                            GoTo NextMatch ' Skip this match
                        End If

                        ' All conditions passed - write to WS4
                        ' Avoid duplicates by checking if this combination already exists
                        If Not DuplicateExists(ws4, ws1.Cells(i, 2).Value, ws3.Cells(matchRow3, 19).Value) Then
                            ws4.Cells(outputRow, 1).Value = ws1.Cells(i, 2).Value ' WS1.B
                            ws4.Cells(outputRow, 2).Value = ws1.Cells(i, 4).Value ' WS1.D
                            ws4.Cells(outputRow, 3).Value = ws1.Cells(i, 24).Value ' WS1.X
                            ws4.Cells(outputRow, 4).Value = ws1.Cells(i, 9).Value ' WS1.I
                            ws4.Cells(outputRow, 5).Value = ws1.Cells(i, 10).Value ' WS1.J
                            ws4.Cells(outputRow, 6).Value = ws1.Cells(i, 11).Value ' WS1.K
                            ws4.Cells(outputRow, 7).Value = ws2.Cells(matchRow2, 2).Value ' WS2.B
                            ws4.Cells(outputRow, 8).Value = ws2.Cells(matchRow2, 2).Value ' WS2.B (duplicate)
                            ws4.Cells(outputRow, 9).Value = ws3.Cells(matchRow3, 19).Value ' WS3.S
                            ws4.Cells(outputRow, 10).Value = ws3.Cells(matchRow3, 22).Value ' WS3.V
                            ws4.Cells(outputRow, 11).Value = ws3.Cells(matchRow3, 34).Value ' WS3.AH

                            outputRow = outputRow + 1
                        End If

NextMatch:
                    Next match3
                End If
            Next match
        End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Comparison complete! Results written to WS4." & vbCrLf & _
           "Total matches found: " & (outputRow - 2), vbInformation

    Exit Sub

ErrorHandler:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Error during comparison: " & Err.Description, vbCritical
End Sub

Function FindMatches(ws As Worksheet, searchValue As Variant, searchColumn As Long) As Collection
    ' Find all matching rows in a worksheet column
    Dim matches As Collection
    Set matches = New Collection

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, searchColumn).End(xlUp).Row

    Dim i As Long
    For i = 2 To lastRow
        ' Extract number from cell if it contains text (e.g., "123 Description")
        Dim cellValue As String
        cellValue = CStr(ws.Cells(i, searchColumn).Value)

        Dim numberPart As String
        numberPart = Split(cellValue, " ")(0) ' Get first part before space

        If numberPart = CStr(searchValue) Or cellValue = CStr(searchValue) Then
            matches.Add i
        End If
    Next i

    Set FindMatches = matches
End Function

Function DuplicateExists(ws As Worksheet, value1 As Variant, value2 As Variant) As Boolean
    ' Check if combination already exists to prevent duplicates
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    If lastRow < 2 Then
        DuplicateExists = False
        Exit Function
    End If

    Dim i As Long
    For i = 2 To lastRow
        If ws.Cells(i, 1).Value = value1 And ws.Cells(i, 9).Value = value2 Then
            DuplicateExists = True
            Exit Function
        End If
    Next i

    DuplicateExists = False
End Function