Recherche et extraction de données multiples

=SUPPRESPACE(INDEX($A:$A;PETITE.VALEUR(SI($C$1:$C$100=E$2;LIGNE($C$1:$C$100));LIGNE(A1)))&" "&INDEX($B:$B;PETITE.VALEUR(SI($C$1:$C$100=E$2;LIGNE($C$1:$C$100));LIGNE(A1))))

=SUPPRESPACE(INDEX($A$1:$A$100&" "&$B$1:$B$100;PETITE.VALEUR(SI($C$1:$C$100=E$2;LIGNE($C$1:$C$100));LIGNE(A1))))

=SUPPRESPACE(INDEX($A$1:$A$100&" "&$B$1:$B$100;PETITE.VALEUR(SI($C$1:$C$100=E$2;LIGNE($C$1:$C$100));LIGNE(A1))))

Option Explicit
Sub Transpose()
Dim a, i As Long, j As Long, x, derLig As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        With CreateObject("System.Collections.SortedList")
            For i = 3 To UBound(a, 1)
               'a(i, 3) = StrConv(a(i, 3), vbUpperCase)
                .Item(a(i, 3)) = .Item(a(i, 3)) & Chr(2) & a(i, 1) & " " & a(i, 2)
                derLig = Application.Max(derLig, _
                                         UBound(Split(Mid$(.Item(a(i, 3)), 2), Chr(2))))
            Next
            ReDim a(1 To derLig + 2, 1 To .Count)
            For i = 0 To .Count - 1
                a(1, i + 1) = .GetKey(i)
            Next
            For i = 0 To .Count - 1
                x = Split(Mid$(.GetByIndex(i), 2), Chr(2))
                For j = 0 To UBound(x)
                    a(j + 2, i + 1) = x(j)
                Next
            Next
        End With
        'Résultat dans la même feuille
        With .Offset(1, .Columns.Count + 5).Resize(UBound(a, 1), UBound(a, 2))
            .CurrentRegion.Clear
            .Value = a
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .BorderAround ColorIndex:=1, Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround ColorIndex:=1, Weight:=xlThin
                .Interior.ColorIndex = 15
            End With
            .Columns(1).Resize(, .Columns.Count).ColumnWidth = 8
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Sub Transpose1()
Dim a, i As Long, w, n As Long, derLig As Long, e
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 3 To UBound(a, 1)
                If Not .exists(a(i, 3)) Then
                    .Item(a(i, 3)) = VBA.Array(a(i, 3))
                End If
                w = .Item(a(i, 3))
                ReDim Preserve w(UBound(w) + 1)
                w(UBound(w)) = a(i, 1) & " " & a(i, 2)
                .Item(a(i, 3)) = w
                derLig = Application.Max(derLig, UBound(w) + 1)
            Next
            ReDim a(1 To derLig, 1 To .Count)
            For Each e In .items
                n = n + 1
                For i = 0 To UBound(e)
                    a(i + 1, n) = e(i)
                Next
            Next
        End With
        With .Offset(1, .Columns.Count + 5).Resize(derLig, n)
            .CurrentRegion.Clear
            .Value = a
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .BorderAround ColorIndex:=1, Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround ColorIndex:=1, Weight:=xlThin
                .Interior.ColorIndex = 15
            End With
            .Columns(1).Resize(, .Columns.Count).ColumnWidth = 8
        End With
    End With
    Application.ScreenUpdating = False
End Sub