Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Transposer toutes les trois lignes l'un en dessous de l'autre

Loïc DUBOIS

XLDnaute Occasionnel
Bonjour à tous,

J'espère que vous allez bien ?

Je créé cette discussion aujourd'hui car j'ai un problème que je n'arrive pas à resoudre.

J'ai un fichier d'environ 65k lignes. Je voudrais prendre les trois première lignes puis les coller en transposer. Puis prendre les trois suivantes et les coller en dessous du collage précédent et ainsi de suite.

Je vous joins un fichier exemple. Feuille 1 : mon fichier de base. Feuille 2 : Ligne 1 à 3 coller en transposer et en dessous ligne 4 à 6 coller en transposer. Etant donné ma grande base de données, il faut que je puisse automatiser cela.

J'espère que vous serez en mesure de m'aider.

Si vous avez besoin de précision n'hésitez pas.

Merci d'avance,

Loïc DUBOIS
 

Pièces jointes

  • transposer fichier ent test.xlsx
    359.2 KB · Affichages: 9

job75

XLDnaute Barbatruc
Bonjour à tous,

On peut stocker le tableau transposé dans une ListBox :
VB:
Sub Transpose_ListBox()
Dim tablo, ncol%, i&, j%, n&
With [A1].CurrentRegion
    tablo = .Resize(3 * Application.RoundUp(.Rows.Count / 3, 0)) 'matrice, plus rapide
End With
ncol = UBound(tablo, 2)
ReDim a(1 To ncol * UBound(tablo) / 3, 1 To 3)
For i = 1 To UBound(tablo) Step 3
    For j = 1 To ncol
        n = n + 1
        a(n, 1) = tablo(i, j)
        a(n, 2) = tablo(i + 1, j)
        a(n, 3) = tablo(i + 2, j)
Next j, i
If n Then ListBox1.List = a Else ListBox1.Clear
End Sub
Aucun problème avec un tableau source de 63 750 lignes, la macro s'exécute chez moi en 6 secondes.

A+
 

Pièces jointes

  • transposer(3).xlsm
    362.4 KB · Affichages: 1

job75

XLDnaute Barbatruc
Bonjour Loîc DUBOIS, le forum,

Avec la ListBox on peut copier et coller les lignes sélectionnées, fichier (4) :
VB:
Sub Coller()
Dim i&, n&
With Sheets("Coller")
    .Cells.Delete 'RAZ
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            n = n + 1
            .Cells(n, 1) = ListBox1.List(i, 0)
            .Cells(n, 2) = ListBox1.List(i, 1)
            .Cells(n, 3) = ListBox1.List(i, 2)
        End If
    Next
    .Columns.AutoFit 'ajuste les largeurs
    .Activate 'facultatif
End With
End Sub
A+
 

Pièces jointes

  • transposer(4).xlsm
    366.1 KB · Affichages: 1

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…