Macro copier/coller transposer

Version imprimable

16/08/2022, 10h41
MaxiRch

1 pièce(s) jointe(s)

Macro copier/coller transposer

Bonjour à tous,

J'ai besoin de votre aide pour la création d'une macro permettant de copier/coller transposer un nombre de lignes indéfini. Après plusieurs tentatives je n'y arrive toujours pas...

Rien de mieux qu'un exemple pour illustrer mon besoin que vous trouverez en pièce jointe (Feuil1 est la base initiale et Feuil2 le résultat attendu)

Merci d'avance de votre aide ! :)

Bonjour,

Une façon de faire:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Option Explicit
 
Sub CopieTranspose()
    Dim wshA As Worksheet, wshB As Worksheet
    Dim kRA As Long, kCA As Long, kRB As Long
    Set wshA = ThisWorkbook.Worksheets("Feuil1")
    Set wshB = ThisWorkbook.Worksheets("Feuil2")
    wshB.Cells.Clear
    wshA.Range("A1:I1").Copy wshB.Range("A1:I1")
    wshB.Range("J1") = "Mois"
    wshB.Range("K1") = "Volume"
    kRA = 2
    kRB = 2
    With wshA
        While .Cells(kRA, 1) <> ""
            .Range(.Cells(kRA, 1), .Cells(kRA, 9)).Copy wshB.Range(wshB.Cells(kRB, 1), wshB.Cells(kRB + 11, 1))
            .Range(.Cells(1, 10), .Cells(1, 21)).Copy
            wshB.Cells(kRB, 10).PasteSpecial Transpose:=True
            .Range(.Cells(kRA, 10), .Cells(kRA, 21)).Copy
            wshB.Cells(kRB, 11).PasteSpecial Transpose:=True
            kRA = kRA + 1
            kRB = kRB + 12
        Wend
    End With
End Sub

Cordialement.

Merci Eric !

Ci-dessous mon code (qui ressemble au votre). Cela fonctionne mais le temps de traitement est assez long (presque 10min). Mon fichier de base comporte plus de 10000 lignes, pensez-vous que cela est lié ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub mise_en_forme()
 
    Dim n As Long, i As Long
        n = 1
        i = 1
 
    Application.ScreenUpdating = False
 
    Sheets.Add.Name = "BDD"
    For i = 2 To (WorksheetFunction.CountA(Worksheets("Feuil1").Range("A:A")))
        Worksheets("Feuil1").Select
        Range(Cells(i, 1), Cells(i, 9)).Copy
        Worksheets("BDD").Select
        Range(Cells(n, 1), Cells(n + 11, 1)).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ActiveSheet.Paste
 
        Worksheets("Feuil1").Select
        Range(Cells(1, 10), Cells(1, 22)).Copy
        Worksheets("BDD").Select
        Cells(n, 10).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
 
 
        Worksheets("Feuil1").Select
        Range(Cells(i, 10), Cells(i, 22)).Copy
        Worksheets("BDD").Select
        Cells(n, 11).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
 
        n = n + 12
    Next
 
    Application.ScreenUpdating = True
 
End Sub

Voir ce que donne ceci (non testé):

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub mise_en_forme()
    Dim n As Long, i As Long
    n = 1
    i = 1
    Application.ScreenUpdating = False
    Sheets.Add.Name = "BDD"
    Worksheets("BDD").Select
    With Worksheets("Feuil1")
        For i = 2 To WorksheetFunction.CountA(.Range("A:A"))
            .Range(.Cells(i, 1), .Cells(i, 9)).Copy
            Range(Cells(n, 1), Cells(n + 11, 1)).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            .Range(.Cells(1, 10), .Cells(1, 22)).Copy
            Cells(n, 10).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Range(.Cells(i, 10), .Cells(i, 22)).Copy
            Cells(n, 11).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            n = n + 12
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Cordialement.

P.S. ajouter Application.Calculation = xlCalculationManual au début et Application.Calculation = xlCalculationAutomatic à la fin.

17/08/2022, 08h22
Alex020181

1 pièce(s) jointe(s)

Bonjour,

Une proposition en PJ.

Sur mon PC 10 000 lignes en 3 secondes.

Teste et dis-nous.

PS; j'ai mis des données bidons à la suite de tes lignes.
17/08/2022, 09h22
MaxiRch

Merci beaucoup Alex ! Ca marche parfaitement ! :)