Snasui Excel Forum

Code: Select all

Sub NoMatch()
Dim r1, r2, c1, c2, Ar, Ac1, Ac2 As Range
    Windows("Project1.xlsx").Activate
    Range("B2").Select
    With ThisWorkbook.Sheets("Sheet1")
    Set Ac1 = .Range(.Cells(2, 2), .Cells(2, .Cells(2, .Columns.Count).End(xlToLeft).Column))
    Set Ar1 = .Range("b2:b" & .Cells(.Rows.Count, 2).End(xlUp).Row)
    End With
    Set Ac2 = Workbooks("Project1.xlsx").Sheets("Sheet1").Range(Cells(2, 2), Cells(2, Cells(2, Columns.Count).End(xlToLeft).Column))
    Set Ar2 = Workbooks("Project1.xlsx").Sheets("Sheet1").Range("b2:b" & Cells(Rows.Count, 2).End(xlUp).Row)
    For Each c1 In Ac1
    If IsError(Application.Match(c1, Ac2, 0)) Then
    c1.Resize(Cells(Rows.Count, 2).End(xlUp).Row + 1).Interior.ColorIndex = 6
End If
    Next c1
    For Each r1 In Ar1
If IsError(Application.Match(r1, Ar2, 0)) Then
    r1.Resize(, Cells(2, Columns.Count).End(xlToLeft).Column).Interior.ColorIndex = 6
    End If
    Next r1
Windows("Project2.xlsm").Activate
End Sub

Code: Select all

Dim d1 As Object, d2 As Object, d3 As Object
Dim w1 As Workbook, w2 As Workbook
Dim rAll As Range, r  As Range
Dim rtAll As Range, rt As Range
Dim t As String, s As String
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")

Set w1 = Workbooks("Project1.xlsx")
Set w2 = Workbooks("Project2.xlsx")
With w1.Worksheets(1)
    Set rAll = .Range("b2").CurrentRegion
    For Each r In rAll.Rows(1).Cells
        d1.Add Key:=r.Value, Item:=r.Value
    Next r
    For Each r In rAll.Columns(1).Cells
        d2.Add Key:=r.Value, Item:=r.Value
    Next r
    For Each r In rAll
        If r.Row > 2 And r.Column > 2 Then
            s = r.Parent.Cells(r.Row, 2).Value & "|" & _
                r.Parent.Cells(2, r.Column).Value & "|" & _
                r.Value
            d3.Add Key:=s, Item:=s
        End If
    Next r
End With
With w2.Worksheets(1)
    Set rtAll = .Range("b2").CurrentRegion
    For Each rt In rtAll
        If rt.Row = 2 Then
            If Not d1.Exists(rt.Value) Then
                rt.Interior.Color = rgbYellow
            End If
        ElseIf rt.Column = 2 Then
            If Not d2.Exists(rt.Value) Then
                rt.Interior.Color = rgbYellow
            End If
        Else
            t = rt.Parent.Cells(rt.Row, 2).Value & "|" & _
                rt.Parent.Cells(2, rt.Column).Value & "|" & _
                rt.Value
            If Not d3.Exists(t) Then
                rt.Interior.Color = rgbYellow
            End If
        End If
    Next rt
End With