Bonjour
@ NathG, vous avez fait cette demande dans les l'espace "Tuto et Astuces" réservé à des astuces ou des Tutos
Il eu été mieux de poster votre demande dans le forum dédié --> https://forum.excel-pratique.com/excel
Voici toutefois une réponse
Sub Transfert() 'sur feuil2
Dim tablo()
Dim dcl As Integer, dlg As Integer, i As Integer, j As Integer
dcl = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
For j = 3 To dcl
dlg = ActiveSheet.Cells(ActiveSheet.Rows.Count, j).End(xlUp).Row
ReDim tablo(2 To dlg, 1 To 4)
For i = 2 To dlg
tablo(i, 1) = ActiveSheet.Cells(i, 1)
tablo(i, 2) = ActiveSheet.Cells(i, 2)
tablo(i, 3) = ActiveSheet.Cells(1, j)
tablo(i, 4) = ActiveSheet.Cells(i, j)
Next i
With ActiveSheet
lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & lig & ":D" & lig + dlg - 2) = tablo
End With
Next j
End Sub
Cordialement