XL 2019 Code VBA pour passer colonnes à lignes

Julio2021 · 14 Avril 2021

Bonjour à tous, je viens d'extraire une base de donnée d'un progiciel et elle sort de façon assez bizarre. En effet j'ai environ 2000 clients qui ont achetée 33 produits chacun avec du 33 colonnes pour le produit HT et 33 avec le produit TTC.

Pour résumer

Ce que j'ai ;
Client 1 : Produit 1 HT / PRIX / Produit 2 HT / PRIX / ... PRODUIT 33 HT / PRIX / PRODUIT 1 TTC / PRIX / PRODUIT 2 TTC / PRIX/ ... PRODUIT 33 TCC / PRIX
Client 2 : Produit 1 HT / PRIX / Produit 2 HT / PRIX / ... PRODUIT 33 HT / PRIX / PRODUIT 1 TTC / PRIX / PRODUIT 2 TTC / PRIX/ ... PRODUIT 33 TCC / PRIX
Client 3 : Produit 1 HT / PRIX / Produit 2 HT / PRIX / ... PRODUIT 33 HT / PRIX / PRODUIT 1 TTC / PRIX / PRODUIT 2 TTC / PRIX/ ... PRODUIT 33 TCC / PRIX
...
Client 2000 : Produit 1 HT / PRIX / Produit 2 HT / PRIX / ... PRODUIT 33 HT / PRIX / PRODUIT 1 TTC / PRIX / PRODUIT 2 TTC / PRIX/ ... PRODUIT 33 TCC / PRIX

Ce que je veux ;
Client 1 Produit 1 HT / PRIX / PRODUIT 1 TTC / PRIX
Client 1 Produit 2 HT / PRIX / PRODUIT 2 TTC / PRIX
Client 1 Produit 3 HT / PRIX / PRODUIT 3 TTC / PRIX
...
Client 1 Produit 33 HT / PRIX / PRODUIT 33 TTC / PRIX
Client 2 Produit 1 HT / PRIX / PRODUIT 1 TTC / PRIX
Client 2 Produit 2 HT / PRIX / PRODUIT 2 TTC / PRIX
Client 2 Produit 3 HT / PRIX / PRODUIT 3 TTC / PRIX
...
Client 2 Produit 33 HT / PRIX / PRODUIT 33 TTC / PRIX
(33 fois au total pour chaque client )

Merci d'avance et cordialement

pierrejean · 14 Avril 2021

bonjour JUlio
A tester

soan · 14 Avril 2021

Bonjour Julio, pierrejean,

ton fichier en retour.

* tu peux voir que la 2ème feuille est vide

* va sur la 1ère feuille, et fais Ctrl e

* patiente un moment. (environ 15 secondes sur mon PC)

VB:

Option Explicit

Sub Essai()
  If ActiveSheet.Name <> "CE QUE J'AI" Then Exit Sub
  Dim n&: n = Cells(Rows.Count, 1).End(3).Row: If n = 1 Then Exit Sub
  Dim i&, j&, k&: n = n - 1: j = 1: Application.ScreenUpdating = 0
  With Worksheets("CE QUE JE VEUX")
    For i = 1 To n
      With .Cells(j, 1)
        .Resize(33) = "Client " & i
        With .Offset(, 1)
          .Value = "Produit HT 1": .AutoFill .Resize(33), 4
          .Resize(33).Interior.Color = 16764159: .Resize(33).Borders.LineStyle = 1
        End With
        With .Offset(, 3)
          .Value = "Produit TTC 1": .AutoFill .Resize(33), 4
          .Resize(33).Interior.Color = 13366271: .Resize(33).Borders.LineStyle = 1
        End With
        k = i + 1
        Cells(k, 2).Resize(, 33).Copy
        With .Offset(, 2)
          .PasteSpecial -4163, , , True
          With .Resize(33)
            .Interior.Color = 16182238: .Borders.Color = 15123356: .Borders.LineStyle = 1
          End With
        End With
        Cells(k, 35).Resize(, 33).Copy
        With .Offset(, 4)
          .PasteSpecial -4163, , , True
          With .Resize(33)
            .Interior.Color = 16182238: .Borders.Color = 15123356: .Borders.LineStyle = 1
          End With
        End With
      End With
      j = j + 33
    Next i
    .Select: [A1].Select
  End With
End Sub

si besoin, tu peux demander une adaptation.
à te lire pour avoir ton avis.

soan

soan · 16 Avril 2021

Bonjour Julio, pierrejean,

j'ai optimisé la partie du code VBA qui met les couleurs et les bordures.

VB:

Option Explicit

Sub Essai()
  If ActiveSheet.Name <> "CE QUE J'AI" Then Exit Sub
  Dim n&: n = Cells(Rows.Count, 1).End(3).Row: If n = 1 Then Exit Sub
  Dim i&, j&, k&: n = n - 1: j = 1: Application.ScreenUpdating = 0
  With Worksheets("CE QUE JE VEUX")
    For i = 1 To n
      With .Cells(j, 1)
        .Resize(33) = "Client " & i
        With .Offset(, 1): .Value = "Produit HT 1": .AutoFill .Resize(33), 4: End With
        With .Offset(, 3): .Value = "Produit TTC 1": .AutoFill .Resize(33), 4: End With
        k = i + 1
        Cells(k, 2).Resize(, 33).Copy: .Offset(, 2).PasteSpecial -4163, , , True
        Cells(k, 35).Resize(, 33).Copy: .Offset(, 4).PasteSpecial -4163, , , True
      End With
      j = j + 33
    Next i
    j = j - 1
    With .[B1].Resize(j): .Interior.Color = 16764159: .Borders.LineStyle = 1: End With
    With .[D1].Resize(j): .Interior.Color = 13366271: .Borders.LineStyle = 1: End With
    With .[C1].Resize(j)
      .Interior.Color = 16182238: .Borders.Color = 15123356: .Borders.LineStyle = 1
    End With
    With .[E1].Resize(j)
      .Interior.Color = 16182238: .Borders.Color = 15123356: .Borders.LineStyle = 1
    End With
    .Select: [A1].Select
  End With
End Sub

soan

Julio2021 · 20 Avril 2021

soan à dit:

Bonjour Julio, pierrejean,

j'ai optimisé la partie du code VBA qui met les couleurs et les bordures.

VB:

Option Explicit

Sub Essai()
  If ActiveSheet.Name <> "CE QUE J'AI" Then Exit Sub
  Dim n&: n = Cells(Rows.Count, 1).End(3).Row: If n = 1 Then Exit Sub
  Dim i&, j&, k&: n = n - 1: j = 1: Application.ScreenUpdating = 0
  With Worksheets("CE QUE JE VEUX")
    For i = 1 To n
      With .Cells(j, 1)
        .Resize(33) = "Client " & i
        With .Offset(, 1): .Value = "Produit HT 1": .AutoFill .Resize(33), 4: End With
        With .Offset(, 3): .Value = "Produit TTC 1": .AutoFill .Resize(33), 4: End With
        k = i + 1
        Cells(k, 2).Resize(, 33).Copy: .Offset(, 2).PasteSpecial -4163, , , True
        Cells(k, 35).Resize(, 33).Copy: .Offset(, 4).PasteSpecial -4163, , , True
      End With
      j = j + 33
    Next i
    j = j - 1
    With .[B1].Resize(j): .Interior.Color = 16764159: .Borders.LineStyle = 1: End With
    With .[D1].Resize(j): .Interior.Color = 13366271: .Borders.LineStyle = 1: End With
    With .[C1].Resize(j)
      .Interior.Color = 16182238: .Borders.Color = 15123356: .Borders.LineStyle = 1
    End With
    With .[E1].Resize(j)
      .Interior.Color = 16182238: .Borders.Color = 15123356: .Borders.LineStyle = 1
    End With
    .Select: [A1].Select
  End With
End Sub

soan

Merci beaucoup ça fonctionne c'est super super gentil !

soan · 20 Avril 2021

merci pour ton retour !

XL 2019 Code VBA pour passer colonnes à lignes

Julio2021

XLDnaute Nouveau

Pièces jointes

pierrejean

XLDnaute Barbatruc

Pièces jointes

soan

XLDnaute Barbatruc

Pièces jointes

soan

XLDnaute Barbatruc

Pièces jointes

Julio2021

XLDnaute Nouveau

soan

XLDnaute Barbatruc

Discussions similaires