Code VBA pour transposer des colonnes en lignes

Le 24/06/2017 à 14:11

Bonjour,

Voici le genre de tableau Excel que j'ai (peut comporter des dizaines de milliers de lignes !) sur 4 colonnes

A B C D

Référence1 Date1 produit1 1236.45

Référence1 Date1 produit2 1400.45

Référence1 Date1 produit4 1500.00

Référence2 Date2 produit2 1200.00

Référence2 Date2 produit4 1000.00

Référence3 Date3 produit3 1250.00

Référence3 Date3 produit4 1300.00

notes:

Chaque référence a la même date et plusieurs produits possibles, mais pas toujours le même nombre (certaines en ont 1 seul, d'autres 20...donc la réf. apparaît sur 1 ligne ou sur 20...)

J'ai besoin d'un code VBA qui puisse me transposer en UNE SEULE ligne pour chaque référence comme cela:

Réf Date Produit1 Produit2 Produit3 Produit4 « lignes d’entête »

Référence1 Date1 1236.45 1400.45 1500.00

Référence2 Date2 1200.00 1000.00

Référence3 Date3 1250.00 1300.00

Le tableau résultat pourrait être crée idéalement sur une deuxième feuille.

je vous serai très reconnaissant pour une éventuelle aide, ce serait un aide énorme pour moi.

Merci!

Le 24/06/2017 à 14:46

Bonjour,

et si tu déposais un fichier de structure identique avec 20-30 lignes et les explications dedans ainsi que le résultat demandé ?

P.

Le 25/06/2017 à 10:30

Bonjour, Salut patrick,

Bien entendu, ça serait idéal d'avoir un fichier comme dit patrick1957. Faute de mieux, j'ai travaillé avec les données fournies dans le message. A essayer :

Option Explicit
Sub test()
    Dim derLig%, i%, j%, k%, lig%, col%, wsSource As Worksheet, wsDest As Worksheet
    Set wsSource = Sheets(1)
    Set wsDest = Sheets(2)
    derLig = wsSource.Range("A" & Rows.Count).End(xlUp).Row
    'entêtes des colonnes
    wsDest.Cells(1, 1) = "Référence"
    wsDest.Cells(1, 2) = "Date"
    j = 3
    k = 2
    For i = 1 To derLig
        With wsSource
            'entête des colonnes produits
            If WorksheetFunction.CountIf(wsDest.Rows(1), .Cells(i, "C")) = 0 Then
                wsDest.Cells(1, j) = .Cells(i, "C")
                j = j + 1
            End If
            'entêtes des lignes
            If WorksheetFunction.CountIf(wsDest.Columns(1), .Cells(i, "A")) = 0 Then
                wsDest.Cells(k, "A") = .Cells(i, "A")
                wsDest.Cells(k, "B") = .Cells(i, "B")
                k = k + 1
            End If
            'valeurs selon les entêtes
            lig = WorksheetFunction.Match(.Cells(i, "A"), wsDest.Columns(1), 0)
            col = WorksheetFunction.Match(.Cells(i, "C"), wsDest.Rows(1), 0)
            wsDest.Cells(lig, col) = .Cells(i, "D")
        End With
    Next i
    Set wsSource = Nothing
    Set wsDest = Nothing
End Sub

Édit : Salut Thauthème

Le 25/06/2017 à 10:59

bonjour

quel est le but de cette opération ?

tu vas te retrouver avec des milliers de lignes, c'est illisible à l'écran, c'est donc que tu veux faire des statistiques, synthèses par produit, par semaines, mois, années

dès lors il ne faut rien toucher à ton tableau de départ, il faut l'exploiter avec un TCD

pour te montrer la puissance des TCD, voici un exemple pour construire ce que tu veux. Sans toucher aux données de départ, et sans VBA

juste une colonne de "pointage" avec une formule simpliste.

Les TCD sont très rapides, même avec des milliers de lignes.

ATTENTION : c'est un exemple. En fait je pense que tu n'as pas besoin de cette présentation. Il faudra créer un TCD qui te donne directement ton BUT.

363tests66.xlsx (12.99 Ko)
Le 25/06/2017 à 18:16

Bonjour le fil, bonjour l forum,

J'arrive bien après la bagarre mais comme je m'y étais bien pris la tête, je me permets quand même de poster ma proposition avec le code commenté ci-dessous :

Sub Macro2()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Long 'déclare la variable NL (Nombre de Lignes)
Dim D1 As Object 'déclare la variable D1 (Dictionnaire 1)
Dim D2 As Object 'déclare la variable D2 (Dictionnaire 2)
Dim TMP1 As Variant 'déclare la variable TMP1 (tableau TeMPoraire 1)
Dim TMP2 As Variant 'déclare la variable TMP2 (tableau TeMPoraire 2)
Dim TET As Variant 'déclare la variable TET (Tableau des En-Têtes)
Dim NET As Integer 'déclare la variable NET (Nombre d'En-Têtes)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim M As Integer 'déclare la variable M (incrément)
Dim NB As Integer 'déclare la variable NB (NomBre)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim D As Long 'déclare la variable D (Date en entier long)

Set OS = Worksheets("Feuil1") 'définit l'onglet source OS (à adapter)
Set OD = Worksheets("Feuil2") 'définit l'onglet destination OD (à adapter)
OD.Range("A1").CurrentRegion.ClearContents 'efface d'éventuelles anciennes données de l'onglet OD
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
Set D1 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D1
Set D2 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D2
For I = 2 To NL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D1(TV(I, 1)) = "" 'alimente le dictionnaire D1 avec les données en colonne 1 de TV (références)
    D2(TV(I, 3)) = "" 'alimente le dictionnaire D2 avec les données en colonne 3 de TV (Produits)
Next I 'prochaine ligne de la boucle
TMP1 = D1.keys 'récupère dans la tableau temporaire TMP1 la liste des éléments du dictionnaire D1 sans doublon
TMP2 = D2.keys 'récupère dans la tableau temporaire TMP2 la liste des éléments du dictionnaire D2 sans doublon
Call Tri(TMP1, LBound(TMP1), UBound(TMP1)) 'tri alphabétique du tableau TMP1
Call Tri(TMP2, LBound(TMP2), UBound(TMP2)) 'tri alphabétique du tableau TMP2
OD.Range("A1").Value = "Référence" 'écrit [Référence] dans la cellule A1 de l'onglet OD
OD.Range("B1").Value = "Date" 'écrit [Date] dans la cellule B1 de l'onglet OD
OD.Range("C1").Resize(1, D2.Count) = TMP2 'renvoie le tableau TMP2 dans la cellule C1 redimensionnée de l'onglet OD
TET = OD.Range("A1:" & OD.Cells(1, Application.Columns.Count).End(xlToLeft).Address(0, 0)) 'définit le tableau des en-têtes TET
NET = Application.WorksheetFunction.CountA(OD.Rows(1)) 'définit le nombre de valeurs (donc de colonnes) du tableau des en-têtes TET
K = 1 'initialise la variable K
For J = 0 To UBound(TMP1) 'boucle 1 : sur tous les éléments du tableau temporaire TMP1
    'définit le nombre de fois NB que l'élément apparaît dans la colonne 1 de l'onglet source OS
    NB = Application.WorksheetFunction.CountIf(OS.Columns(1), TMP1(J))
    For M = 1 To NB 'boucle 2 : sur les M fois de 1 à NB
        For I = 2 To NL 'boucle 3 : sur toutes les lignes I du tableau des valeurs NL (en partant de la seconde)
            If TV(I, 1) = TMP1(J) Then 'condition : si la donnée ligne I colonne 1 de TV est égale à l'élément J du tableau TMP1
                ReDim Preserve TL(1 To NET, 1 To K) 'redimensionne le tableau des lignes TN
                TL(1, K) = TV(I, 1) 'récupère la référence dans la ligne 1 de TL
                D = DateSerial(Year(TV(I, 2)), Month(TV(I, 2)), Day(TV(I, 2))) 'définit la date D (en entier long)
                TL(2, K) = D 'récupère la date D dans la ligne 2 de TL
                    For L = 1 To NET 'boucle 4 : sur toutes les colonnes L de 1 à NET
                        'si la donnée lige 1 colonne L de TET est égale au produit TV(I,3),
                        'récupère dans la ligne L colonne K de TL la valeur TV(I,4) et sort de la boucle 4
                        If TET(1, L) = TV(I, 3) Then TL(L, K) = TV(I, 4): Exit For
                    Next L 'procahine colonne de la boucle 4
            End If 'fin de la condition
        Next I 'prochaine ligne de la boucle 3
    Next M 'prochaine fois de la boucle 2
    K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
Next J 'prochain élément de la boucle 1
'si K est supérieure à 1, renvoie dans A2 redimensionnée le tableau TL transposé
If K > 1 Then OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
OD.Columns(2).NumberFormat = "dd/mm/yyy" 'formate les dates de la colonne 2 de l'onglet destination OD
End Sub

Sub Tri(a, gauc, droi) ' Quick sort 'tiré du site de Jacques Boisgontier (http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm)
ref = a((gauc + droi) \ 2)
g = gauc: D = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(D): D = D - 1: Loop
    If g <= D Then
        TMP = a(g): a(g) = a(D): a(D) = TMP
        g = g + 1: D = D - 1
    End If
Loop While g <= D
If g < droi Then Call Tri(a, g, droi)
If gauc < D Then Call Tri(a, gauc, D)
End Sub
Le 26/06/2017 à 09:14

Bonjour le fil, bonjour le forum,

J'enrage Raja !... Quand je vois la simplicité et l'efficacité de ton code. Chapeau !...

Le 26/06/2017 à 09:21

Hello à tous,

et avec ça l'intéressé n'a pas envoyé de fichier...

P.

Le 26/06/2017 à 10:11

Bonjour le fil, bonjour le forum,

Oui Patrick ! Si au moins s'appelait Adam, on pourrait dire qu'il rame Adam (de Sagesse évidemment)...

Le 27/06/2017 à 03:48

salut tout le monde . tout d'abord je m'excuse pour ce retard qui est du à la célébration d'une fête. pour le fichier souhaité

voila je vais essayer d'envoyer un , en ce qui concerne l’utilité du code vba souhaité ; c'est pour élaborer et imprimer mensuellement le tableau,puis l'envoyer par émail.

pour les codes VBA proposés je vais les essayer, tout en remerciant leurs auteurs

et merci une autre fois pour tout l’intérêt donné à ma question .

200produits.xlsx (20.20 Ko)
Le 27/06/2017 à 10:37

re

avec un TC

pas de VBA

j'ai laissé les totaux au cas où il y ait plusieurs dates pour une ref.

204produits.xlsx (18.17 Ko)
Le 27/06/2017 à 22:04

Bonsoir à tous,

Avant l'orage :

Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, t As Long, dico1 As Object, dico2 As Object
    Set dico1 = CreateObject("Scripting.Dictionary")
    dico1.CompareMode = 1
    Set dico2 = CreateObject("Scripting.Dictionary")
    With Sheets("SOURCE").Range("a1").CurrentRegion
        a = .Value: ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        b(1, 1) = "N°": b(1, 2) = "Référence": b(1, 3) = "date"
        n = 1: t = 3
        For i = 2 To UBound(a, 1)
            If Not dico1.exists(a(i, 2)) Then
                t = t + 1
                dico1(a(i, 2)) = t
                If UBound(b, 2) < t Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 10)
                End If
                b(1, t) = a(i, 2)
            End If
            If Not dico2.exists(a(i, 1)) Then
                n = n + 1
                dico2(a(i, 1)) = n
                b(n, 1) = n - 1
                b(n, 2) = a(i, 1)
                b(n, 3) = a(i, 3)
            End If
            b(dico2(a(i, 1)), dico1(a(i, 2))) = b(dico2(a(i, 1)), dico1(a(i, 2))) + a(i, 4)
        Next
    End With
    Application.ScreenUpdating = False
    'restitution et mise en forme
    With Sheets("Feuil1").Range("a1")
        .CurrentRegion.Clear
        With .Resize(n, t)
            .Value = b
            .Cells(1, .Columns.Count + 1).Value = "Total"
            .Cells(2, .Columns.Count + 1).Resize(.Rows.Count - 1).Formula = "=sum(rc[-" & .Columns.Count - 3 & "]:rc[-1])"
            With .CurrentRegion
                .Font.Name = "calibri"
                .Font.Size = 10
                .VerticalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    With .Resize(, 3)
                        .Interior.ColorIndex = 40
                    End With
                    With .Offset(, 3).Resize(, .Columns.Count - 4)
                        .Interior.ColorIndex = 44
                    End With
                    .Cells(.Columns.Count).Interior.ColorIndex = 45
                End With
                With .Columns(1)
                    .Resize(, 3).HorizontalAlignment = xlCenter
                    With .Offset(1).Resize(.Rows.Count - 1)
                        .Interior.ColorIndex = 36
                    End With
                End With
            End With
        End With
        Set dico1 = Nothing: Set dico2 = Nothing
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 30/06/2017 à 15:43

Bonjour .

Tout d'abord je remercie tout ceux qui ont donné un intérêt à ma demande.

Voila j'ai trouvé une solution en utilisant des formules Excel simples sans recours aux codes vba.

un classeur est annexé à ma présente

et Merci une autre fois pour tout le monde.

cordialement .

243produits-v2.xlsx (20.12 Ko)
Rechercher des sujets similaires à "code vba transposer colonnes lignes"