Détecter une cellule

Option Explicit

Sub nonossov_color()

Dim critere As Range, matrice As Range
Set critere = [Feuil1!A2]   ' position de la première cellule où se trouvent les critères
Set matrice = [Feuil2!A1]   ' position de la cellule en haut à gauche de la table à colorier
Dim ncol As Long, icol As Long
Dim nlig As Long, fcol As Long
Dim ws As Worksheet
Dim col As Scripting.Dictionary
Set col = New Scripting.Dictionary
Dim lig As Scripting.Dictionary
Set lig = New Scripting.Dictionary
Dim horval() As Long
Dim numcol As Long
Dim verval As Long

' parcourons et mémorisons les critères de recherche
ncol = critere.Column
nlig = critere.Row
Set ws = critere.Worksheet
Do While ws.Cells(nlig, ncol) <> ""
    col.Add ws.Cells(nlig, ncol).Value, nlig
    lig.Add ws.Cells(nlig, ncol + 1).Value, nlig
    nlig = nlig + 1
Loop

' parcourons les titres de colonnes, et mémorisons leur positions dans les critères de recherche
ncol = matrice.Column
nlig = matrice.Row
numcol = 0
Set ws = matrice.Worksheet
Do While ws.Cells(nlig, ncol + 1) <> ""
    ncol = ncol + 1
    numcol = numcol + 1
    ReDim Preserve horval(1 To numcol)
    If lig.Exists(ws.Cells(nlig, ncol).Value) Then
        horval(numcol) = lig(ws.Cells(nlig, ncol).Value)
    Else
        horval(numcol) = 0
    End If
Loop

' parcourons la table à colorier
nlig = matrice.Row + 1
fcol = matrice.Column
' parcourons chaque ligne
Do While ws.Cells(nlig, fcol) <> ""
    If col.Exists(ws.Cells(nlig, fcol).Value) Then
        ' le titre de ligne est à rechercher
        verval = col(ws.Cells(nlig, fcol).Value)
        ' parcourons chaque colonne de cette ligne
        For icol = 1 To numcol
            If verval = horval(icol) Then
                ' le titre de colonne et le titre de ligne forment un critère de recherche
                ' colorions la cellule
                ws.Cells(nlig, fcol + icol).Interior.ColorIndex = 37
            End If
        Next icol
    End If
    nlig = nlig + 1
Loop
    
End Sub

Option Explicit

Sub nonossov_color()

Dim critere As Range, matrice As Range
Set critere = [Feuil1!A3]
Set matrice = [Feuil2!A1]
Dim ncol As Long, icol As Long
Dim nlig As Long, fcol As Long
Dim ws As Worksheet
Dim col As Scripting.Dictionary
Set col = New Scripting.Dictionary
Dim lig As Scripting.Dictionary
Set lig = New Scripting.Dictionary
Dim horval() As Long
Dim numcol As Long
Dim verval As Long

ncol = critere.Column
nlig = critere.Row
Set ws = critere.Worksheet
Do While ws.Cells(nlig, ncol) <> ""
    col.Add ws.Cells(nlig, ncol).Value, nlig
    lig.Add ws.Cells(nlig, ncol + 1).Value, nlig
    nlig = nlig + 1
Loop
ncol = matrice.Column
nlig = matrice.Row
numcol = 0
Set ws = matrice.Worksheet
Do While ws.Cells(nlig, ncol + 1) <> ""
    ncol = ncol + 1
    numcol = numcol + 1
    ReDim Preserve horval(1 To numcol)
    If lig.Exists(ws.Cells(nlig, ncol).Value) Then
        horval(numcol) = lig(ws.Cells(nlig, ncol).Value)
    Else
        horval(numcol) = 0
    End If
Loop
nlig = matrice.Row + 1
fcol = matrice.Column
Do While ws.Cells(nlig, fcol) <> ""
    If col.Exists(ws.Cells(nlig, fcol).Value) Then
        verval = col(ws.Cells(nlig, fcol).Value)
        For icol = 1 To numcol
            If verval = horval(icol) Then
                ws.Cells(nlig, fcol + icol).Interior.ColorIndex = 37
            End If
        Next icol
        nlig = nlig + 1
    End If
Loop
    
End Sub