XL 2019 Code VBA pour passer colonnes à lignes

Julio2021

XLDnaute Nouveau
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
 

Pièces jointes

  • Test Client.xlsx
    845.6 KB · Affichages: 17

soan

XLDnaute Barbatruc
Inactif
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
 

Pièces jointes

  • Test Client.xlsm
    520.6 KB · Affichages: 2

soan

XLDnaute Barbatruc
Inactif
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
 

Pièces jointes

  • Test Client.xlsm
    520.7 KB · Affichages: 5

Julio2021

XLDnaute Nouveau
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 !
 

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 848
dernier inscrit
Djigbenou