Recherche de valeurs dans plusieurs colonnes

' Ajouter la référence Microsoft scripting runtime
Sub transposer_noms()
     
    Dim champs As New Dictionary
    Dim champ As Object
    Dim début_champs, plage, plage_noms, plage_champs As Range
    Dim i, c As Integer
    Dim clé As Variant
    Dim noms() As String
    
    Set début_champs = [A1]
    Set plage_utilisée = ActiveSheet.UsedRange
    Set plage_noms = plage_utilisée.Rows(1)  'noms : en ligne 1                           '
    Set plage_champs = plage_utilisée.Offset(1).Resize(plage_utilisée.Rows.Count - 1) 'champs : des lignes 2 à la dernière utilisée
    
    'ajout des champs en clé avec pour chaque clé  le tableau des noms associés
    i = 0
    For Each champ In plage_champs.Cells
        
        If Not IsEmpty(champ.Value) Then
            If Not champs.Exists(champ.Value) Then
                ReDim noms(1)
                noms(0) = plage_noms.Columns(champ.Column).Value
                champs.Add Key:=champ.Value, Item:=noms
            Else
                noms = champs(champ.Value)
                i = UBound(noms)
                ReDim Preserve noms(i + 1)
                noms(i) = plage_noms.Columns(champ.Column)
                champs(champ.Value) = noms
            End If
        End If
    
    Next
    
    If champs.Count > 0 Then
        'initialisation de la nouvelle plage des champs
        plage_utilisée.Clear
        ' remplissage champs de la feuille active à partir de la variable range "début_champs"
        début_champs.Resize(, champs.Count).Value = champs.Keys
        c = 0
        For Each clé In champs.Keys
            noms = champs(clé)
            début_champs.Offset(1, c).Resize(UBound(noms)).Value = Application.Transpose(noms)
            c = c + 1
        Next
   End If

End Sub