Transposer un tableau vertical variable en tableau horizontal fixe.

**Marc-L** · 06/01/2016, 10h48

Faut dire que les explications ne sont pas toujours limpides …
Mais je m'en doutais et j'avais anticipé ceci en réserve toujours à partir du classeur du post #14 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub Demo1a()
                                        Const TD = "Total_Données"
    With Feuil1.UsedRange
        L& = Application.CountIf(.Columns(1), TD)
        VA = .Value
    End With
    With Feuil2.UsedRange.Rows
        NC = .Item(1).Value
        C& = .Columns.Count
        ReDim TR(1 To L, 1 To C)
        If .Count > 1 Then .Item("2:" & .Count).Clear
    End With
    For R& = 2 To UBound(VA)
        If VA(R, 1) = TD Then
            TR(N&, C - 1) = VA(R, 3):  TR(N, C) = -VA(R, 4)
        ElseIf IsNumeric(VA(R, 2)) Then
                         V = Application.Match(VA(R, 1), NC, 0)
            If IsNumeric(V) Then TR(N, V) = VA(R, 2) - VA(R, 3)
        Else
            N = N + 1:  TR(N, 1) = VA(R, 1):  TR(N, 2) = VA(R, 2)
        End If
    Next
    With Feuil2.[A2].Resize(L, C)
        .NumberFormat = "[Blue]* #,##0.00_$;[Red]* #,##0.00_$;; @ "
               .Value = TR
    End With
End Sub

______________________________________________________________________________________________________

Merci de cliquer sur

pour chaque message ayant aidé …

**RastaBomboclat** · 06/01/2016, 12h28

Bonjour Marc-L,

Merci pour ton code que je viens de tester. Mais même après avoir due déclarer les variables (Dim L&, VA, NC, C&, R&, N&, V, TR), j’ai toujours un message d’erreur sur la ligne 20.
Run-time error ‘9’ : Subscript out of range

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
            N = N + 1:  TR(N, 1) = VA(R, 1):  TR(N, 2) = VA(R, 2)

" : TR(N, 2) = VA(R, 2)" c'est cette partie-ci qui est surlignée

je suis plus dans les code VBA. Et se code s'apparente à du pure VB6, selon moi

Marc-L,

Voici en annexe, la feuille excel oú j'ai complété les commentaire.

A noter que ce qui est "Donnée_1" est en fait le code employé qui est unique pour chaque employé.

Merci de l'assistance.Convert_Transpose - Format Initial à Final _Marc-L.xls

**Marc-L** · 06/01/2016, 12h52

Envoyé par RastaBomboclat

Et ce code s'apparente à du pure VB6, selon moi

Tout ce que je te propose est testé sous Excel donc VBA !

L'as-tu au moins testé avec le fichier joint dans le post #14 tel quel ?!

**RastaBomboclat** · 06/01/2016, 13h42

Oui Marc-L,

Je l'ai testé avec le fichier. Je l'ai joint pour voir si je n'ai pas commis une petite erreur quelque part, on ne sait jamais.

Merci.

**Theze** · 06/01/2016, 14h17

Bonjour,

Pour que le code de Marc fonctionne, il faut que dans la feuille "Format Final" tu ai les entêtes de colonnes à demeure : A1 et B1 vides (ou pas !), et ensuite C1=Donnée_2, D1=Donnée_3, etc... Alors que mon code par d'une feuille vierge.

**RastaBomboclat** · 06/01/2016, 14h45

Oui Theze,

Ton code comme celui de Klin89 ont bien fonctionné jusqu'à ce que l'on me demande de regrouper les crédit et débit. Pour les totaux c facile pour moi, je le fais en deux seconde (façon de parler

). Et c'est la que se trouve mon probleme.

**Theze** · 06/01/2016, 14h51

Mais maintenant, tout fonctionne comme tu veux quel que soit le code utilisé ?

**Marc-L** · 06/01/2016, 14h53

Je l'ai pourtant indiqué plusieurs fois : « à partir du fichier joint du post #14 » tel quel !

Donc RastaBomboclat, l'as-tu au moins testé avec ce fichier là comme joint dans le post #14 ?

Car aucun souci de mon côté :

S'il faut partir d'une feuille de destination vide, j'ai en stock une version pour pas beaucoup plus de lignes de code …

Edit : en fait la version ne comporte pas plus de lignes de code !

**RastaBomboclat** · 06/01/2016, 21h18

Non Theze,
Ca ne marche plus comme je le souhaiterai, parce qu'il m'avait était demandé(Apres avoir reçu ton code et celui de Klin89), d'ordonner les colonne en Débit et Crédit.
Ci-dessous le code qui marche le mieux pour moi, mais qui a juste besion d'une touche additionnelle pour que tout soit completement fini. Je souhaiterai que la macro puisse separer(ou regrouper) les debit d'une part et les crédit d'autre part, comme dans mon exemple #32 (image collé) ou comme dans la video de Marc-L.

Voici le code (ci-dessous de Klin89) qui devrait être retoucher pour qu'il organise les débit d'un coté et les crédit de l'autre, et c'est bon pour moi. Parce qu'avec ce code j'ai la possibilité d'avoir N colonnes avec des noms de titre differents sans avoir besoin de changer le code vba.

Merci à vous tous qui participez, très gentil, merci beaucoup

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Option Explicit
 
Sub test()
Dim myAreas As Areas, i As Long, j As Long, t As Long, y
Dim tablo
    Application.ScreenUpdating = False
    ReDim tablo(1 To 1)
    With Sheets("Format Initial")
        With .Range("a2", .Range("a" & Rows.Count).End(xlUp))
            On Error Resume Next
            '.ColumnDifferences(.Find("Total_Données", lookat:=xlWhole)).Select
            Set myAreas = .ColumnDifferences(.Find("Total_Données", lookat:=xlWhole)).Areas
            On Error GoTo 0
        End With
    End With
    If myAreas Is Nothing Then Exit Sub
    'Restitution
    With Sheets("Feuil1")
        For i = 1 To myAreas.Count
            For j = 1 To myAreas(i).Rows.Count
                If j = 1 Then
                    .Cells(i + 1, 1).Value = myAreas(i).Cells(j).Offset(, 1).Value
                    .Cells(i + 1, 2).Value = myAreas(i).Cells(j).Value
                Else
                    y = Application.Match(myAreas(i).Cells(j).Value, tablo, 0)
                    If IsError(y) Then
                        t = t + 1
                        .Cells(1, t + 2).Value = myAreas(i).Cells(j).Value
                        ReDim Preserve tablo(1 To t)
                        tablo(t) = myAreas(i).Cells(j).Value
                        y = t
                    End If
                    If myAreas(i).Cells(j).Offset(, 2).Value <> 0 Then
                        .Cells(i + 1, y + 2).Value = myAreas(i).Cells(j).Offset(, 2).Value
                    Else
                        .Cells(i + 1, y + 2).Value = myAreas(i).Cells(j).Offset(, 1).Value
                    End If
                End If
            Next
        Next
        Set myAreas = Nothing
        With .Cells(1).CurrentRegion
            With .Rows(1)
                With .Offset(, 2).Resize(, .Columns.Count - 2)
                    .Font.Size = 11
                    .Interior.ColorIndex = 43
                    .Borders(xlInsideVertical).Weight = xlThin
                    .BorderAround Weight:=xlThin
                End With
            End With
            With .Offset(1).Resize(.Rows.Count - 1)
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

**Marc-L** · 06/01/2016, 23h47

Pas clair pour moi …

Sinon à partir du classeur joint dans le post #32 avec la feuille de destination vierge et les CodeName en anglais :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Demo2()
                                        Const TD = "Total_Données"
    With Sheet1.UsedRange
        L& = Application.CountIf(.Columns(1), TD)
        VA = .Value
    End With
    With CreateObject("Scripting.Dictionary")
        For R& = 2 To UBound(VA)
         If VA(R, 1) <> TD And IsNumeric(VA(R, 2)) And Not .Exists(VA(R, 1)) Then .Add VA(R, 1), .Count + 3
        Next
                                ReDim TR(1 To L, 1 To .Count + 4)
        For R = 2 To UBound(VA)
                If VA(R, 1) = TD Then TR(N&, .Count + 3) = VA(R, 3): TR(N, .Count + 4) = -VA(R, 4) Else _
          If IsNumeric(VA(R, 2)) Then TR(N, .Item(VA(R, 1))) = VA(R, 2) - VA(R, 3) _
                                 Else N = N + 1: TR(N, 1) = VA(R, 1): TR(N, 2) = VA(R, 2)
        Next
                 Sheet2.UsedRange.Clear
        Sheet2.Cells(1).Resize(L + 1, .Count + 4).NumberFormat = "[Blue]* #,##0.00_$;[Red]* #,##0.00_$;; @ "
                        Sheet2.Cells(3).Resize(, .Count).Value = .Keys
                    Sheet2.Cells(.Count + 3).Resize(, 2).Value = Split("Total_Debit Total_Credit")
                       Sheet2.[A2].Resize(L, .Count + 4).Value = TR
        .RemoveAll
    End With
End Sub

______________________________________________________________________________________________________

Merci de cliquer sur

pour chaque message ayant aidé …

**RastaBomboclat** · 07/01/2016, 15h39

Finalement j'ai la dernière version du code. ÇA MARCHE

Merci Marc-L pour ton code et pour ta patience. Vraiment merci.
C’est le code qu’il conclue ce travail. Si on me demande un autre

A vous tous qui avez participé, Theze, Klin89 et à toute la communauté Developpez.net,

P.S.:
Cette foi c'est vraiment

pour de vrai.

**Marc-L** · 07/01/2016, 18h46

Au cas où j'avais déjà préparé ceci (meilleur format de colonnes) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Sub Demo2a()
                Dim oDic As Object, L&, N&, R&, TD$, VA
                Set oDic = CreateObject("Scripting.Dictionary")
    With Sheet1.UsedRange
        TD = .Cells(4).End(xlDown)(1, -2).Value
         L = Application.CountIf(.Columns(1), TD)
        VA = .Value
    End With
    With Sheet2
               .UsedRange.Clear
        For R = 2 To UBound(VA)
            If VA(R, 1) <> TD And IsNumeric(VA(R, 2)) And Not oDic.Exists(VA(R, 1)) Then
                .Cells(oDic.Count + 3).Font.ColorIndex = 4 + Sgn(VA(R, 2) - VA(R, 3))
                oDic.Add VA(R, 1), oDic.Count + 3
            End If
        Next
                                ReDim TR(1 To L, 1 To oDic.Count + 4)
        For R = 2 To UBound(VA)
                If VA(R, 1) = TD Then TR(N, oDic.Count + 3) = VA(R, 3): TR(N, oDic.Count + 4) = -VA(R, 4) Else _
          If IsNumeric(VA(R, 2)) Then TR(N, oDic.Item(VA(R, 1))) = VA(R, 2) - VA(R, 3) _
                                 Else N = N + 1: TR(N, 1) = VA(R, 1): TR(N, 2) = VA(R, 2)
        Next
        .Cells(1).Resize(L + 1, oDic.Count + 4).NumberFormat = "[Blue] * #,##0.00 ;[Red] * #,##0.00 ;; @ "
                                .UsedRange.Rows(1).Font.Bold = True
                        .Cells(3).Resize(, oDic.Count).Value = oDic.Keys
                    .Cells(oDic.Count + 3).Resize(, 2).Value = [{"Total Débit","Total Crédit"}]
                       .[A2].Resize(L, oDic.Count + 4).Value = TR
        .UsedRange.Columns.AutoFit
    End With
                    oDic.RemoveAll
                Set oDic = Nothing
End Sub

Edit : sans constante pour "Total_Données" …

**RastaBomboclat** · 07/01/2016, 21h52

Merci Marc-L

Pour les ligne de code de formatage des couleurs de colonnes. Ça fait bien plus beau et je vais essayer d'utiliser ces codes sur d'autre projet, pour embelir um peu mes feuilles.

Bonne Année

**Marc-L** · 07/01/2016, 23h03

Merci !

Bonne année à toi aussi et tous mes meilleurs vœux de réussite dans tes futurs développements !

______________________________________________________________________________________________________
Je suis Charlie, …

**Marc-L** · 08/01/2016, 11h17

Question de pure logique, pas besoin de chercher le nom "Total_Données", il suffit juste de s'intéresser à la colonne D
car s'il y a un montant dans cette colonne, c'est forcément une ligne de totalisation :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub Demo2b()
                Dim oDic As Object, L&, N&, R&, VA
                Set oDic = CreateObject("Scripting.Dictionary")
    With Sheet1.UsedRange
         L = Application.CountA(.Columns(4))
        VA = .Value
    End With
    With Sheet2
               .UsedRange.Clear
        For R = 2 To UBound(VA)
            If IsNumeric(VA(R, 2)) And VA(R, 4) = "" And Not oDic.Exists(VA(R, 1)) Then
                .Cells(oDic.Count + 3).Font.ColorIndex = 4 + Sgn(VA(R, 2) - VA(R, 3))
                oDic.Add VA(R, 1), oDic.Count + 3
            End If
        Next
                                 ReDim TR(1 To L, 1 To oDic.Count + 4)
        For R = 2 To UBound(VA)
         If oDic.Exists(VA(R, 1)) Then TR(N, oDic.Item(VA(R, 1))) = VA(R, 2) - VA(R, 3) Else _
                 If VA(R, 4) > "" Then TR(N, oDic.Count + 3) = VA(R, 3): TR(N, oDic.Count + 4) = -VA(R, 4) _
                                  Else N = N + 1: TR(N, 1) = VA(R, 1): TR(N, 2) = VA(R, 2)
        Next
        .Cells(1).Resize(L + 1, oDic.Count + 4).NumberFormat = "[Blue] * #,##0.00 ;[Red] * #,##0.00 ;; @ "
                                .UsedRange.Rows(1).Font.Bold = True
                        .Cells(3).Resize(, oDic.Count).Value = oDic.Keys
                    .Cells(oDic.Count + 3).Resize(, 2).Value = [{"Total Débit","Total Crédit"}]
                       .[A2].Resize(L, oDic.Count + 4).Value = TR
        .UsedRange.Columns.AutoFit
    End With
                    oDic.RemoveAll
                Set oDic = Nothing
End Sub

Avec cette optique vis à vis de Demo2a modifications en lignes n°2, 5 (NBVAL à la place de NB.SI), 11, 18 & 19 …

**Klin89** · 17/01/2016, 19h28

Bonsoir à tous,

Pour le fun et toujours avec la méthode ColumnDifferences.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Option Explicit
 
Sub test()
Dim myAreas As Areas, b(), x, temp, i As Long, j As Long, n As Long
    Application.ScreenUpdating = False
    x = Array("Code", "Nom", "Donnée_2", "Donnée_3", "Donnée_4", "Donnée_5", _
              "Donnée_6", "Donnée_7", "Donnée_8", "Donnée_9", "Donnée_10", _
              "Donnée_11", "Donnée_12", "Donnée_13", "Donnée_14", "Donnée_15", _
              "Total_Débit", "Total_Crédit"): n = 1
    With Sheets("Format Initial")
        With .Range("a2", .Range("a" & Rows.Count).End(xlUp))
            On Error Resume Next
            '.ColumnDifferences(.Find("Total_Données", lookat:=xlWhole)).Select
            Set myAreas = .ColumnDifferences(.Find("Total_Données", lookat:=xlWhole)).Areas
            On Error GoTo 0
            ReDim b(1 To .Rows.Count, 1 To UBound(x) + 1)
            For i = 0 To UBound(x)
                b(1, i + 1) = x(i)
            Next
        End With
    End With
    If myAreas Is Nothing Then Exit Sub
    For i = 1 To myAreas.Count
        n = n + 1
        With myAreas(i)
            b(n, 1) = .Cells(1, 1).Value
            b(n, 2) = .Cells(1, 2).Value
            For j = 2 To .Rows.Count
                temp = Application.Match(.Cells(j).Value, x, 0)
                b(n, temp) = IIf(.Cells(j, 2).Value <> 0, .Cells(j, 2).Value, .Cells(j, 3).Value)
            Next
            b(n, UBound(b, 2) - 1) = Application.Sum(.Cells(2, 2).Resize(.Rows.Count - 1))
            b(n, UBound(b, 2)) = Application.Sum(.Cells(2, 3).Resize(.Rows.Count - 1))
        End With
    Next
    Set myAreas = Nothing
    'Restitution et mise en forme
    With Sheets("Feuil1").Cells(1)
        .Parent.Cells.Clear
        .Resize(n, UBound(b, 2)) = b
        With .CurrentRegion
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .BorderAround Weight:=xlThin
                With .Offset(, 2).Resize(, .Columns.Count - 11)
                    .Interior.ColorIndex = 43
                End With
                With .Offset(, 9).Resize(, .Columns.Count - 11)
                    .Interior.ColorIndex = 19
                End With
                With .Offset(, 16).Resize(, .Columns.Count - 16)
                    .Interior.ColorIndex = 15
                End With
            End With
            With .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
                .NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
            End With
            .Columns.ColumnWidth = 12
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Transposer un tableau vertical variable en tableau horizontal fixe.

Macros et VBA Excel

Discussions similaires

Partager

Partager