XL 2019 Transposer VBA

mapomme à dit:

Bonsoir @undo74,

Testez ce code :

VB:

Sub Ventiler()
Dim t, r, i&, j&, n&
   t = Sheets("Data").Range("a1").CurrentRegion
   ReDim r(1 To 1 + (UBound(t) - 1) * (UBound(t, 2) - 1), 1 To 3)
   n = 1: r(n, 1) = t(1, 1): r(n, 2) = "Zone": r(n, 3) = "VAL %"
   For i = 2 To UBound(t)
      For j = 2 To UBound(t, 2)
         n = n + 1: r(n, 1) = t(i, 1): r(n, 2) = t(1, j): r(n, 3) = t(i, j)
      Next j
   Next i
   Sheets("Résultat").Range("a1").CurrentRegion.ClearContents
   Sheets("Résultat").Range("a1").Resize(UBound(r), 3) = r
   Sheets("Résultat").Range("a1").CurrentRegion.Columns(3).NumberFormat = "0%"
End Sub

Cliquez pour agrandir...