XL 2019 VBA Une ligne vers plusieurs colonnes

[Sylveo]

Bonjour à tous,

Je cherche à réaliser un code VBA qui me permet de couper une plage de données vers une seule ligne et inversement.
J'ai déjà un code qui marche bien, mais je souhaiterais qu'il soit sur une plage fixe.
Et il marche malheureusement que dans le sens "plages vers une ligne".

Je ne sais pas comment coder ça en peu de ligne. J'y arrive, mais cellule par cellule.

Si l'un de vous connait le code pour cette manipulation, je suis plus que preneur.

Merci d'avance.
Sylveo.

 

[fanch55]

Bonjour,
Testez le code ci-dessous :

Sub ConvertRangeToGroupOfColumns()

Dim Range1 As Range, Range2 As Range, Rng As Range
Dim RowIndex As Integer, Nc As Integer, G As Variant, I As Integer

    xTitleId = "Xl-Downloads"
    Set Range1 = Application.Selection
    Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
    Nc = Range1.Cells(Range1.Cells.Count).End(xlToLeft).Column
    Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
    G = Application.InputBox("Columns by group :", xTitleId, Nc, Type:=1)
    RowIndex = 0
    Application.ScreenUpdating = False
        For Each Rng In Range1.Rows
            For I = 1 To Nc Step G
                Rng.Cells(I).Resize(, G).Copy
                Range2.Offset(RowIndex).PasteSpecial Paste:=xlPasteAll ' , Transpose:=True
                RowIndex = RowIndex + 1
            Next
        Next
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Cousinhub]

Bonjour,
En utilisant Power Query (en natif dans ta version d'Excel) pour passer d'une ligne à un tableau.
Le code :

let
    Source = Excel.CurrentWorkbook(){[Name="T_Data"]}[Content],
    Transpose = Table.Transpose(Source),
    Table = Table.FromRows(List.Split(Transpose[Column1],5), {"Descriptif", "Prix U", "Qté","Prix HT","TVA"})
in
    Table

Pour mettre à jour, clic droit dans la requête, "Actualiser"
Bonne journée

 

[fanch55]

Salut @Cousinhub ,
Par curiosité, tu t'en sors comment avec plusieurs lignes de données ?

 

[Cousinhub]

Hello @fanch55
Une autre logique, très peu différente

let
    Source = Excel.CurrentWorkbook(){[Name="T_Data2"]}[Content],
    AjtIdx = Table.AddIndexColumn(Source, "Index", 1, 1, Int64.Type),
    UnPivot = Table.UnpivotOtherColumns(AjtIdx, {"Index"}, "Attribut", "Valeur"),
    Table = Table.FromRows(List.Split(UnPivot[Valeur],5), {"Descriptif", "Prix U", "Qté","Prix HT","TVA"})
in
    Table

Edit : version également valable pour une seule ligne

 

[fanch55]

Oki, pas mal ...
Et si tu dois conserver le type de cellules et de couleurs ?

 

[Cousinhub]

Oki, pas mal ...
Et si tu dois conserver le type de cellules et de couleurs ?

Hi,
C'est pour faire un comparatif avec VBA? Je ne rentrerai pas dans ce jeu, désolé...
Et pour ma part, j'utilise les Tableaux Structurés, donc couleurs et autres éléments de décorations....
A savoir que le format des TS peut être modifié, que les MEFC fonctionnent parfaitement dans les requêtes une fois insérées.
Bonne journée

 

[fanch55]

Hi,
C'est juste pour savoir ce qu'on peut faire facilement ou pas avec Pq,
et surtout pour la souplesse de maj sans avoir à modifier le code de Pq .
Je n'ai pas de à priori, que de la curiosité intéressée .
C'est bien évidemment pour faire un comparatif avec Vba,
si Pq est mieux et facilement modulable, je suis pour ce qui est le plus rapide ...

 

[Cousinhub]

Hi,
Pas de soucis
Question rapidité, je ne pense pas que PQ soit le plus véloce. (du moins, s'il y a peu de données à traiter)
Cependant, comme son nom l'indique, c'est bien pour manipuler des données, i-e importer, transformer, restituer.
Dire que c'est mieux, je ne pourrais le dire, mais perso, j'ai pratiquement cessé le VBA, sauf pour les mises à jour et autres petits trucs, qui facilitent la vie.
Chacun ses préférences, le principal, c'est le résultat, et c'est tout ce qui compte.

 

[Sylveo]

Bonjour,
Testez le code ci-dessous :

Sub ConvertRangeToGroupOfColumns()

Dim Range1 As Range, Range2 As Range, Rng As Range
Dim RowIndex As Integer, Nc As Integer, G As Variant, I As Integer

    xTitleId = "Xl-Downloads"
    Set Range1 = Application.Selection
    Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
    Nc = Range1.Cells(Range1.Cells.Count).End(xlToLeft).Column
    Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
    G = Application.InputBox("Columns by group :", xTitleId, Nc, Type:=1)
    RowIndex = 0
    Application.ScreenUpdating = False
        For Each Rng In Range1.Rows
            For I = 1 To Nc Step G
                Rng.Cells(I).Resize(, G).Copy
                Range2.Offset(RowIndex).PasteSpecial Paste:=xlPasteAll ' , Transpose:=True
                RowIndex = RowIndex + 1
            Next
        Next
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Bonjour,


Déjà, merci beaucoup pour votre aide.

Cependant, ce code reproduit la même ligne, seul le nombre de colonne reproduit change selon la valeur qu'on choisi.

Je n'arrive pas à lui faire mettre la suite de la ligne source vers la ligne suivante.

Merci d'avance.

 

[Sylveo]

Bonjour,
En utilisant Power Query (en natif dans ta version d'Excel) pour passer d'une ligne à un tableau.
Le code :

let
    Source = Excel.CurrentWorkbook(){[Name="T_Data"]}[Content],
    Transpose = Table.Transpose(Source),
    Table = Table.FromRows(List.Split(Transpose[Column1],5), {"Descriptif", "Prix U", "Qté","Prix HT","TVA"})
in
    Table

Pour mettre à jour, clic droit dans la requête, "Actualiser"
Bonne journée

Bonjour,

Cela semble effectivement marcher, mais je souhaite rester en VBA sans faire appel au cloud.

Merci d'avance.

 

[fanch55]

Bonjour,
Déjà, merci beaucoup pour votre aide.
Cependant, ce code reproduit la même ligne, seul le nombre de colonne reproduit change selon la valeur qu'on choisi.
Je n'arrive pas à lui faire mettre la suite de la ligne source vers la ligne suivante.
Merci d'avance.

Salut, une petite "bévue" dans le code pour ne pas traiter une ligne entière sans raison.
Correction:

Sub Lignecolonne()

Dim Range1 As Range, Range2 As Range, Rng As Range
Dim RowIndex As Integer, Nc As Integer, G As Variant, I As Integer

    xTitleId = "Xl-Downloads"
    On Error Resume Next
        Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Selection.Address, Type:=8)
    On Error GoTo 0
    If Not Range1 Is Nothing Then
        If Range1.Cells(Range1.Columns.Count) = "" Then
            Nc = Range1.Cells(Range1.Columns.Count).End(xlToLeft).Column
        Else
            Nc = Range1.Columns.Count
        End If
        Set Range2 = Application.InputBox("Convert to (single cell) :", xTitleId, Type:=8)
        G = Application.InputBox("Columns by group :", xTitleId, Nc, Type:=1)
        RowIndex = 0
        Application.ScreenUpdating = False
            For Each Rng In Range1.Rows
                For I = 1 To Nc Step G
                    Rng.Cells(I).Resize(, G).Copy
                    Range2.Offset(RowIndex).PasteSpecial Paste:=xlPasteAll ' , Transpose:=True
                    RowIndex = RowIndex + 1
                Next
            Next
            Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If
End Sub

 

[Sylveo]

Merci beaucoup, ça marche parfaitement et dans les deux sens.

Je l'ai même automatisé sur une plage donnée fixe :

Sub Lignecolonne()

Dim Range1 As Range, Range2 As Range, Rng As Range
Dim RowIndex As Integer, Nc As Integer, G As Variant, I As Integer

    xTitleId = "Xl-Downloads"
    On Error Resume Next
        Set Range1 = Range("A2:T2")
    On Error GoTo 0
    If Not Range1 Is Nothing Then
        If Range1.Cells(Range1.Columns.Count) = "" Then
            Nc = Range1.Cells(Range1.Columns.Count).End(xlToLeft).Column
        Else
            Nc = Range1.Columns.Count
        End If
        Set Range2 = Sheets("Resultat").Range("A2")
        G = 5
        RowIndex = 0
        Application.ScreenUpdating = False
            For Each Rng In Range1.Rows
                For I = 1 To Nc Step G
                    Rng.Cells(I).Resize(, G).Copy
                    Range2.Offset(RowIndex).PasteSpecial Paste:=xlPasteAll ' , Transpose:=True
                    RowIndex = RowIndex + 1
                Next
            Next
            Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If
   Sheets("Resultat").Activate
End Sub

 

[Cousinhub]

Bonjour,

Cela semble effectivement marcher, mais je souhaite rester en VBA sans faire appel au cloud.

Merci d'avance.

Bonsoir,
Sauf erreur de ma part, (ce dont j'en suis sûr), je n'ai jamais fait référence à un quelconque "nuage".....
Power Query est juste une fonctionnalité installée en natif dans ta version, tout comme tout plein d'autres, si peu utilisées...
Bonne continuation