[Resolu] Boucles toujours les boucles ou pas

Sub ecrit()
Dim DerLig_max As Integer
Lig = 1
Ligne = 2
Colonne = 1
passe = 0
NomPrenom = ""
Produits = ""
Categorie = ""
Taille = ""
Nbc = ""


Sheets("Feuil1").Select
DerLig = [A5000].End(xlUp).Row
For Lig = 2 To DerLig Step 3
For passe = 0 To 9
    Sheets("Feuil1").Select
    NomPrenom = Cells(Ligne, Colonne)
    Produits = Cells(Ligne, Colonne + 1)
    Categorie = Cells(Ligne, Colonne + 2)
    Taille = Cells(Ligne, Colonne + 4)
    Nbc = Cells(Ligne, Colonne + 9)
    
    Sheets("Feuil2").Select
    Cells(Lig, Colonne + passe + 1) = NomPrenom
    Cells(Lig + 1, Colonne + passe + 1) = Produits
    Cells(Lig + 2, Colonne + passe) = Categorie
    Resultat = Taille & "     " & Nbc
    Cells(Lig + 2, Colonne + passe + 2) = Resultat
    passe = passe + 3
    Ligne = Ligne + 1

Next passe
Next Lig
End Sub

Sub Écrit()
Dim Te(), Le&, Ce&, Ts(), Ls&, Cs&
Te = Feuil1.[A2].Resize(Feuil1.[A5000].End(xlUp).Row - 1, 10).Value
ReDim Ts(1 To ((UBound(Te, 1) + 2) \ 3) * 3, 1 To 11)
Ls = -3: Cs = -4
For Le = 1 To UBound(Te, 1)
   Cs = (Cs + 4) Mod 12: If Cs = 0 Then Ls = Ls + 3
   Ts(Ls + 1, Cs + 2) = Te(Le, 1)
   Ts(Ls + 2, Cs + 2) = Te(Le, 2)
   Ts(Ls + 3, Cs + 1) = Te(Le, 3)
   Ts(Ls + 3, Cs + 3) = Te(Le, 5) & "     " & Te(Le, 10): Next Le
Feuil2.[A1:K5000].ClearContents
Feuil2.[A1].Resize(UBound(Ts, 1), UBound(Ts, 2)).Value = Ts
End Sub