Bonjour,
j'ai mit le résultat en colonne A
à tester,
Sub transfert()
Dim LastRw As Long, lig1 As Integer, lignx As Long, col1 As Integer, colx, i As Integer, y As Long
Dim plg As Range
Set plg = Range("Tableau1")
Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
lig1 = plg.Rows(1).Row - 1 '5
lignx = plg.Rows(plg.Rows.Count).Row '11
col1 = plg.Columns(1).Column '3
colx = plg.Columns(plg.Columns.Count).Column '7
For i = col1 + 1 To colx
LastRw = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(LastRw, 1) = Cells(lig1, i)
For y = lig1 + 1 To lignx
LastRw = Cells(Rows.Count, 1).End(xlUp).Row + 1
If Cells(y, i) = 1 Then
Cells(LastRw, 1) = Cells(y, col1)
End If
Next y
Next i
End Sub