Boucles spéciales

[anber]

Bonjour le Forum, pierrejean

Je recherche un code pour transposer rapidement des données d'une feuille dans une autre
par exemple dans la feuille 1 j'ai :
450 500 396 408 485
je veux obtenir dans la feuille 2
450 500 396 450 500 408 450 500 485

Le fichier original a plus de 30000 lignes

Merci pour votre aide
Ci-joint un fichier d'exemple avec un début de code

 

[pierrejean]

Re : Boucles spéciales

Bonjour amber

Vois si cela te convient

 

[anber]

Re : Boucles spéciales

Bonsoir Pierrejean,

A première celà semble parfait

Encore
merci

Bonne soirée

 

[jp14]

Re : Boucles spéciales

Bonsoir anber
Salut Pierrrejean


Ci dessous une macro avec une autre approche.

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

A tester

JP

 

[anber]

Re : Boucles spéciales

Bonjour jp14,

Ta solution fonctionne aussi, mais moins rapide que celle de pierrejean

Merci

 

[pierrejean]

Re : Boucles spéciales

Re

A propos de vitesse:
une version ultrarapide transmis par Laeticia que je salue

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

 

[anber]

Re : Boucles spéciales

Bonsoir Laeticia, pierrejean

Alors là chapeau bas, c'est le turbo ...

Merci

 

[laetitia90]

Re : Boucles spéciales

bonjour tous
en fin de compte dans ton cas le seul travail c'est sur la colonne 1 le reste c'est de la copy de colonne
on peut faire comme cela c'est plus rapide

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

attention je lance la macro de la feuil base avec un bouton

 

[anber]

Re : Boucles spéciales

Bonsoir Laetica90,

Ta première version semble plus rapide.
Dans les 2 cas c'est plus que parfait

Merci

Bon WE