Sub test()
Dim BaseDepart As Worksheet
Set BaseDepart = Worksheets("Fichier de départ")
Dim Result As Worksheet
Set Result = Worksheets("Je veux que ca ressemble à ça")
Dim Tbase() As Variant
Tbase = BaseDepart.Range(BaseDepart.Cells(1, 1), BaseDepart.Cells(BaseDepart.Cells(6536, 2).End(xlUp).Row, 8))
ReDim Preserve Tbase(LBound(Tbase, 1) To UBound(Tbase, 1), LBound(Tbase, 2) To UBound(Tbase, 2) + 6)
' compteur
Dim cpt As Double
cpt = 0
For i = 7 To UBound(Tbase, 1)
For j = 4 To 8
If Tbase(i, j) = 1 Then
Tbase(i, 9) = Tbase(i, 9) + 1
Tbase(i, Tbase(i, 9) + 9) = Tbase(2, j)
End If
Next j
cpt = cpt + Tbase(i, 9)
Next i
i = Empty
' créer le tableau récap
Dim Trecap() As Variant
ReDim Trecap(1 To cpt, 1 To 2)
cpt = 1
For j = 7 To UBound(Tbase, 1)
For K = 10 To 14
If Tbase(j, K) <> Empty Then
Trecap(cpt, 1) = Tbase(j, 2)
Trecap(cpt, 2) = Tbase(j, K)
cpt = cpt + 1
End If
Next K
Next j
' coller sur la feuille
' on colle le résultat
Result.Cells(2, 1).Resize(UBound(Trecap, 1), UBound(Trecap, 2)) = Trecap
End Sub