Affectation via Index Equiv

=SIERREUR(INDEX($A$2:$A$19;PETITE.VALEUR(SI(B$2:B$19=$G2;LIGNE(B$2:B$19);"");NB.SI($G$2:$G2;$G2))-1);"")

Sub Transposer()
Dim t, i&, j&, m&, ok As Boolean, ntot&
  t = Range("a1").CurrentRegion.Value
  ReDim res(1 To 4 * UBound(t), 1 To UBound(t))
  ntot = 1
  res(ntot, 1) = "Rôle"
  For j = 2 To UBound(t, 2): res(ntot, j) = t(1, j): Next j
  For i = 2 To UBound(t)
    For j = 2 To UBound(t, 2)
      If t(i, j) <> "" Then
        ok = False
        t(i, j) = UCase(t(i, j))
        For m = 2 To ntot
          If res(m, 1) = t(i, j) Then
            If res(m, j) = "" Then
              res(m, j) = t(i, 1)
              ok = True
              Exit For
            End If
          End If
        Next m
        If Not ok Then
          ntot = ntot + 1
          res(ntot, 1) = t(i, j)
          res(ntot, j) = t(i, 1)
        End If
      End If
    Next j
  Next i

  Range("g1").CurrentRegion.Clear
  Range("g1").Resize(UBound(res), ntot) = res
  With Range("g1").CurrentRegion
    .Borders.LineStyle = xlContinuous
    .Sort key1:=Range("g1"), order1:=xlAscending, Header:=xlYes
    .Columns(1).Interior.Color = RGB(200, 200, 200)
    .Columns(1).Font.Color = RGB(50, 50, 250)
    .Columns(1).Font.Bold = True
    .Rows(1).Interior.Color = RGB(200, 200, 200)
    .Rows(1).Font.Bold = True
  End With
End Sub