Boucles spéciales

Sub travdem()
Dim Cel As Range
Dim Nomfeuille1 As String
Dim Col As String
Dim dl1 As Long, i As Long, j As Long, J1 As Long, J2 As Long

'parametre
' pour boucler sur la colonne 1
Nomfeuille1 = "base"
Col = "A"
With Sheets("resultat")
dl1 = Sheets(Nomfeuille1).Range("b" & .Rows.Count).End(xlUp).Row + 1

For i = 1 To dl1
    j = 0
    If Sheets(Nomfeuille1).Range("a" & i) <> "" Then
        Set Cel = Sheets(Nomfeuille1).Range("a" & i)
        Do ' recherche du nombre de ligne
            If Cel.Offset(j, 0).Value <> "" And j <> 0 Then i = i + j - 1: Exit Do
            If Cel.Offset(j, 1).Value = "" Then i = i + j - 1: Exit Do
            j = j + 1
        Loop
        j = j - 1
        Sheets(Nomfeuille1).Range(Cel.Address & ":B" & Cel.Row + j).Copy
        Col = "a"
        dl1 = Sheets("resultat").Range(Col & .Rows.Count).End(xlUp).Row + 1
        .Range("a" & dl1).PasteSpecial Paste:=xlPasteAll
        .Range("e" & dl1).PasteSpecial Paste:=xlPasteAll
        .Range("i" & dl1).PasteSpecial Paste:=xlPasteAll
        .Range("m" & dl1).PasteSpecial Paste:=xlPasteAll
        .Range("q" & dl1).PasteSpecial Paste:=xlPasteAll
        For J1 = dl1 + 1 To dl1 + j
        .Range("a" & J1) = Cel.Value
        .Range("e" & J1) = Cel.Value
        .Range("i" & J1) = Cel.Value
        .Range("m" & J1) = Cel.Value
        .Range("q" & J1) = Cel.Value
        Next J1
        J2 = 0
        For J1 = Cel.Row To Cel.Row + j
            Sheets(Nomfeuille1).Range("c" & J1).Copy
            .Range("c" & dl1 + J2).PasteSpecial Paste:=xlPasteAll
            Sheets(Nomfeuille1).Range("d" & J1).Copy
            .Range("g" & dl1 + J2).PasteSpecial Paste:=xlPasteAll
            Sheets(Nomfeuille1).Range("e" & J1).Copy
            .Range("k" & dl1 + J2).PasteSpecial Paste:=xlPasteAll
            Sheets(Nomfeuille1).Range("f" & J1).Copy
            .Range("o" & dl1 + J2).PasteSpecial Paste:=xlPasteAll
            Sheets(Nomfeuille1).Range("g" & J1).Copy
            .Range("s" & dl1 + J2).PasteSpecial Paste:=xlPasteAll
            J2 = J2 + 1
        Next J1
    End If
Next i

End With
End Sub

Sub es()
Dim t, t1 As Variant, i As Long, c As Byte, v As Long, x As Long, s As Long
s = Timer
Sheets("Feuil1").Cells.ClearContents
i = 0: v = 1
t = Sheets("base").Range("a1:h" & Sheets("base").Cells(Rows.Count, 7).End(xlUp).Row)
ReDim t1(1 To UBound(t), 1 To 20)
For x = 1 To UBound(t)
i = i + 1: v = 1
For Z = 3 To 7
For c = 1 To 2
If t(x, c) = "" Then t(x, c) = t(x - 1, c)
t1(i, v) = t(x, c): v = v + 1
Next c
t1(i, v) = t(x, Z): v = v + 1
t1(i, v) = t(x, 8): v = v + 1
Next Z
Next x
Sheets("Feuil1").Cells(5, 1).Resize(x - 1, 20) = t1
Erase t, t1
Sheets("Feuil1").Select
MsgBox Timer - s
End Sub

Sub es()
Dim t, t1 As Variant, i As Long, c As Byte, v As Long, x As Long, z As Byte, s As Long
s = Timer
Sheets("Feuil1").Cells.ClearContents
t = Range("a1:b" & Cells(Rows.Count, 2).End(xlUp).Row)
ReDim t1(1 To UBound(t), 1 To 2)
For x = 1 To UBound(t)
i = i + 1: v = 1
For c = 1 To 2
If t(x, c) = "" Then t(x, c) = t(x - 1, c)
t1(i, v) = t(x, c): v = v + 1
Next c
Next x
v = 1
For z = 1 To 5
Sheets("Feuil1").Cells(5, v).Resize(x, 2) = t1
v = v + 4
Next z
Erase t, t1
Range("c1:c" & Cells(Rows.Count, 3).End(xlUp).Row).Copy Destination:=Sheets("Feuil1").Range("c5")
Range("d1:d" & Cells(Rows.Count, 4).End(xlUp).Row).Copy Destination:=Sheets("Feuil1").Range("g5")
Range("e1:e" & Cells(Rows.Count, 5).End(xlUp).Row).Copy Destination:=Sheets("Feuil1").Range("k5")
Range("f1:f" & Cells(Rows.Count, 6).End(xlUp).Row).Copy Destination:=Sheets("Feuil1").Range("o5")
Range("g1:g" & Cells(Rows.Count, 7).End(xlUp).Row).Copy Destination:=Sheets("Feuil1").Range("s5")
Sheets("Feuil1").Select
MsgBox Timer - s
End Sub