XL 2019 Code VBA pour passer colonnes à lignes

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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

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

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

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 !
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
1
Affichages
605
Réponses
3
Affichages
463
Retour