Recherche selon plusieurs valeurs

Sub Regroupe()
  Set f = Sheets("feuil1")
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A2:B" & f.[a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
   d(Tbl(i, 1)) = d(Tbl(i, 1)) & Tbl(i, 2) & "|"
  Next i
  Set f2 = Sheets("feuil2")
  f2.[A2].Resize(d.Count) = Application.Transpose(d.keys)
  f2.[B2].Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  f2.Range("B2").Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
  Cells.EntireRow.AutoFit
End Sub

Sub RegroupeUniquesCode()  ' si doublons dans les indices
  Set f = Sheets("feuil1")
  Set d = CreateObject("Scripting.Dictionary")
  Set d1 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A2:B" & f.[a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)    ' élimination doublons pour un code
   If Tbl(i, 2) <> "" Then d1(Tbl(i, 1) & "|" & Tbl(i, 2)) = ""
  Next i
  For Each c In d1.keys     ' regroupement par code
    a = Split(c, "|")
    d(a(0)) = d(a(0)) & a(1) & "|"
  Next c
  Set f2 = Sheets("feuil2")
  n = d.Count
  Dim TblRes: ReDim TblRes(1 To d.Count, 1 To 2)
  i = 0
  For Each c In d.keys
     i = i + 1
     TblRes(i, 1) = c: TblRes(i, 2) = d(c)
  Next c
  f2.[A2].Resize(d.Count, 2) = TblRes
  Application.DisplayAlerts = False
  f2.[B2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
  f2.Cells.EntireRow.AutoFit
End Sub

=SIERREUR(PETITE.VALEUR(SI($A$2:$A$3728=$D2;$B$2:$B$3728);COLONNE(A:A));"")