Comparaison de 2 feuilles Excel et correspondance de cellules

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Address <> "$A$2" Then Exit Sub
    effaceTout
    If Target = "" Then Exit Sub
    Set liste = CreateObject("Scripting.dictionary")
    Set soc = Sheets("Sociétés-Risques")
    Set proc = Sheets("Procédures-Risque")
    Dim monTablo(1) As String
    numLigne = Application.Match(Target, soc.[A1:A200], 0)
    nbCol = Application.CountA(soc.[1:1])
    For Each c In soc.Cells(numLigne, 2).Resize(1, nbCol)
        If UCase(c) = "X" Then liste(soc.Cells(1, c.Column).Value) = "": trouve = True
    Next c
    If trouve Then
        cpt = 2
        For Each risk In liste.keys
            colProc = Application.Match(risk, proc.[1:1], 0)
            For Each x In proc.Cells(2, colProc).Resize(Application.CountA(proc.[A:A]), 1)
                If UCase(x) = "X" Then
                    monTablo(0) = monTablo(0) & proc.Cells(x.Row, 1) & " # "
                    monTablo(1) = monTablo(1) & proc.Cells(x.Row, 2) & " # "
                End If
            Next x
            If monTablo(0) <> "" Then monTablo(0) = Mid(monTablo(0), 1, Len(monTablo(0)) - 3)
            If monTablo(1) <> "" Then monTablo(1) = Mid(monTablo(1), 1, Len(monTablo(1)) - 3)
            Cells(cpt, 2).Resize(1, 2).Value = monTablo
            monTablo(0) = ""
            monTablo(1) = ""
            cpt = cpt + 1
        Next risk
    End If
End Sub
Sub effaceTout()
    With Sheets("Attribution")
        If .[B200].End(xlUp).Row = 1 Then Exit Sub
        .[B2].Resize(Application.CountA(.[B:B]) - 1, 2).Clear
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Address <> "$A$2" Then Exit Sub
    effaceTout
    If Target = "" Then Exit Sub
    
    Set listeRsk = CreateObject("Scripting.dictionary")
    Set listeProc = CreateObject("Scripting.dictionary")
    Set soc = Sheets("Sociétés-Risques")
    Set proc = Sheets("Procédures-Risque")
    
    numLigne = Application.Match(Target, soc.[A1:A200], 0)
    nbCol = Application.CountA(soc.[1:1])
    For Each c In soc.Cells(numLigne, 2).Resize(1, nbCol)
        If UCase(c) = "X" Then listeRsk(soc.Cells(1, c.Column).Value) = "": trouve = True
    Next c
    If trouve Then
        cpt = 2
        For Each risk In listeRsk.keys
            colProc = Application.Match(risk, proc.[1:1], 0)
            For Each x In proc.Cells(2, colProc).Resize(Application.CountA(proc.[A:A]), 1)
                If UCase(x) = "X" Then
                    listeProc(proc.Cells(x.Row, 1).Value) = proc.Cells(x.Row, 2)
                End If
            Next x
        Next risk
        [B2].Resize(listeProc.Count, 1) = Application.Transpose(listeProc.keys)
        [C2].Resize(listeProc.Count, 1) = Application.Transpose(listeProc.items)
    End If
End Sub
Sub effaceTout()
    With Sheets("Attribution")
        If .[B200].End(xlUp).Row = 1 Then Exit Sub
        .[B2].Resize(Application.CountA(.[B:B]) - 1, 2).Clear
    End With
End Sub

For Each x In proc.Cells(2, colProc).Resize(Application.CountA(proc.[A:A]), 1)