XL 2019 Changement d'affichage horizontal à vertical VBA

antoine.jllt

XLDnaute Nouveau
Bonjour,

J'ai crée une macro pour afficher dans une autre feuille les informations en colonne ==> En ligne
En exemple sur la feuille 1 :
1 : 18/03/2022 : 1 4 6 7
2 : 20/03/2022 : 1 5 7 2

pour devenir sur une autre feuille 2 :
1 : 18/03/2022 : 1
1 : 18/03/2022 : 4
1 : 18/03/2022 : 6
1 : 18/03/2022 : 7
2 : ....
.
etc...

Le numéro au début de la ligne est un numéro de commande


J'ai une macro mais le soucis est que quand je la relance, il refait tout de A à Z (j'ai jusquà 200 dates parfois.. donc cela prends 10 ans)

J'aimerais qu'il recommence à partir du dernier numéro de commande saisie dans la feuille 2.

Merci de votre aide :)

Antoine
 

job75

XLDnaute Barbatruc
Bonjour antoine.jllt, bienvenue sur XLD, bonjour chris,

Voyez le fichier joint et cette macro dans le code de Feuil2 :
VB:
Private Sub Worksheet_Activate()
Dim tablo, ncol%, resu(), i&, j%, n&
tablo = Sheets("Feuil1").[A1].CurrentRegion 'matrice, plus rapide
ncol = UBound(tablo, 2)
If ncol > 2 Then ReDim resu(1 To UBound(tablo) * (ncol - 2), 1 To 3)
For i = 1 To UBound(tablo)
    For j = 3 To ncol
        n = n + 1
        resu(n, 1) = tablo(i, 1)
        resu(n, 2) = tablo(i, 2)
        resu(n, 3) = tablo(i, j)
Next j, i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1] '1ère cellule de destination
    If n Then .Resize(n, 3) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub
Elle est très rapide car elle utilise des tableaux VBA.

Un tableau de 200 dates c'est vraiment peanuts.

A+
 

Pièces jointes

  • Transposer(1).xlsm
    17.7 KB · Affichages: 5

antoine.jllt

XLDnaute Nouveau
Quelle rapidité! super merci beaucoup pour ton aide!

Cependant je n'arrive pas à le transposer à mon sujet ...

Je te laisse la pièce jointe, si jamais quelqu'un aurait la sympathie de m'aider :)

L'objectif est de transférer de la liste1 vers la Liste2 avec la même logique.. (les références et qty en ligne plutôt qu'en colonne)

Merci par avance!
 

Pièces jointes

  • Transposer(1) (1).xlsm
    81.2 KB · Affichages: 2

chris

XLDnaute Barbatruc
Bonjour

Une solution PowerQuery

J'ai gardé les X en quantité ne sachant s'ils sont utiles.

Si la source évolue, clic droit dans la liste2, Actualiser
 

Pièces jointes

  • Transposer_PQ.xlsx
    36.7 KB · Affichages: 4

chris

XLDnaute Barbatruc
RE

PowerQuery étant intégré à 2019, je ne vois pas pas comment cela peut le planter.

Peut-être la liaison avec le fichier externe qu'il y a dans ton fichier...

Comprendre les 3 ou 4 manips faites avec PowerQuery te poserait moins de difficulté que VBA puisque tu n'a pas su adapter le code de job75...

Si tu ne souhaites pas évoluer en utilisant les facilités de ta version, je laisse la main à job75 🤝


EDIT : testé depuis le fichier ici posté sur un vieux PC équipé de la version 2019. Pas de plantage
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour antoine.jllt, chris, le forum,

La nouvelle macro adaptée au fichier du post #4 :
VB:
Private Sub Worksheet_Activate()
Dim nlig&, tablo, ncol%, resu(), i&, j%, n&, k%
With Sheets("LISTE")
    nlig = Application.Count(.[A:A])
    If nlig = 0 Then GoTo 1 'si le tableau est vide
    tablo = .Range("A5:AD" & nlig + 4)
End With
ncol = UBound(tablo, 2)
If ncol > 10 Then ReDim resu(1 To nlig * (ncol - 10) \ 2, 1 To 12)
For i = 1 To nlig
    For j = 11 To ncol Step 2
        n = n + 1
        resu(n, 11) = tablo(i, j)
        resu(n, 12) = tablo(i, j + 1)
        For k = 1 To 10
            resu(n, k) = tablo(i, k)
Next k, j, i
'---restitution---
1 If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then
        .Resize(n, 12) = resu
        .Resize(n, 12).Borders.Weight = xlThin 'bordures
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 12).Delete xlUp 'RAZ en dessous
End With
End Sub
Elle se déclenche quand on active la feuille "LISTE2".

A+
 

Pièces jointes

  • Transposer(2).xlsm
    37.5 KB · Affichages: 1

job75

XLDnaute Barbatruc
Dans ce fichier ( 2 bis) les lignes sont créées uniquement quand les colonnes Composant ne sont pas vides :
VB:
Private Sub Worksheet_Activate()
Dim nlig&, tablo, ncol%, resu(), i&, j%, n&, k%
With Sheets("LISTE")
    nlig = Application.Count(.[A:A])
    If nlig = 0 Then GoTo 1 'si le tableau est vide
    tablo = .Range("A5:AD" & nlig + 4)
End With
ncol = UBound(tablo, 2)
If ncol > 10 Then ReDim resu(1 To nlig * (ncol - 10) \ 2, 1 To 12)
For i = 1 To nlig
    For j = 11 To ncol Step 2
        If tablo(i, j) <> "" Then 'colonnes Composant non vides
            n = n + 1
            resu(n, 11) = tablo(i, j)
            resu(n, 12) = tablo(i, j + 1)
            For k = 1 To 10
                resu(n, k) = tablo(i, k)
            Next k
        End If
Next j, i
'---restitution---
1 If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then
        .Resize(n, 12) = resu
        .Resize(n, 12).Borders.Weight = xlThin 'bordures
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 12).Delete xlUp 'RAZ en dessous
End With
End Sub
Les résultats sont alors les mêmes que ceux de chris.
 

Pièces jointes

  • Transposer(2 bis).xlsm
    37.8 KB · Affichages: 0

Discussions similaires

Réponses
8
Affichages
364
Réponses
3
Affichages
539
Réponses
2
Affichages
486

Statistiques des forums

Discussions
311 740
Messages
2 082 047
Membres
101 880
dernier inscrit
Anton_2024