Transposer un tableau vertical variable en tableau horizontal fixe.

Version imprimable

20/12/2015, 21h55
RastaBomboclat

1 pièce(s) jointe(s)

Transposer un tableau vertical variable en tableau horizontal fixe.

Bonjour la communauté,

Je reviens avec un problème qui nécessitera, je pense, une bonne maitrise de la notion des boucles et tableaux. Parce que j’ai essayé de le faire avec les fonctions d’Excel telles que Lookup et VLookup, mais ça n’a pas marché. Voilà pourquoi je me tourne vers les macros.

Au fait, j’aimerai transferer des données d'une tableau(initial) vers un autre(final). Sauf que le tableau final est fixe alors que le tableau initial ne n'est pas. Sur mon tableau initial, la colonne A peut avoir pour le premier sous-total de 3 a 15 lignes de donnée. Alors que dans le tableau final(dans la feuille "Format Final") il y a 15 Colonnes prédefinies qui doivent etre remplies avec les données du tableau initial(qui se trouve dans sur la 1ere feuille "Format Initail").
Pour mieux me faire comprendre je joints un fichier pour mieux illuster la situation.

P.S.: Messieurs les Administrateur du groupe, j'ai en effet une autre question en attente sur un autre post, qui n'est pas encore completement resolu. Je post celle-ci parce que c'est un autre problème auquel je fais face et que je souhaiterai vraiment resoudre avant Noël, voila pourquoi, messieurs les Administrateurs du groupe, je vous pries de ne pas bloquer ce post, mais au contraire d'y contribuer avec une belle solution :D ;) :merci:

Merci à tous pour vos contribution.

Rasta Bomboclat

Bonjour,

Un truc dans le genre ?

Code:

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
 
Sub Test()
 
    Dim Plage As Range
    Dim Cel As Range
    Dim Tbl()
    Dim TblDonnees
    Dim I As Integer
    Dim J As Integer
 
    With Worksheets("Format Initial")
 
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
    'titres des colonnes
    TblDonnees = Array("Donnée_1", "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")
 
    'défini le nombre de lignes du tableau (+ 1 = ligne des titres)
    I = Application.CountIf(Plage, "Total_Données") + 1
 
    'les bornes étant connues, dimensionne le tableau
    ReDim Tbl(1 To I, 1 To UBound(TblDonnees) + 1)
 
    'rempli la première ligne (titres)
    For I = 1 To UBound(TblDonnees) + 1: Tbl(1, I) = TblDonnees(I - 1): Next I
 
    'évite la ligne des titres
    I = 2
 
    For Each Cel In Plage
 
        If Cel.Value <> "Total_Données" Then
 
            'récupère la valeur de la cellule en colonne B (à adapter, Débit=1 ou Crédit=2)
            Tbl(I, Application.Match(Cel.Value, TblDonnees, 0)) = Cel.Offset(, 1).Value
 
        Else
 
            'ligne suivante
            I = I + 1
 
        End If
 
    Next Cel
 
    'colle le tableau dans la feuille
    With Worksheets("Format Final"): .Range(.Cells(1, 1), .Cells(UBound(Tbl, 1), UBound(Tbl, 2))).Value = Tbl: End With
 
End Sub

21/12/2015, 10h05
RastaBomboclat

C'est vraiment Noël!!!
J'ai une réponse en moins de 12h. J'ai dû vraiment assurer cette année; le père Noël viendra, je crois.

Merci Theze!, je l'essaie tout de suite...

Rasta Bomboclat

Merci encore pour ton code Theze.

Il fonctionne mais a moitié. C'est-à-dire que quand la partie Débit fonctionne, la partie Crédit ne fonctionne pas, et vis-vers-ça.
j'ai vu dans le code un commentaire "à adapter", mais mes adaptation ne marchent pas.

Pourrais-tu, s'il te plaît, essayer de trouver une adaptation qui puisse faire fonctionner les deux colonnes (Débít et Crédit)?

Merci a tous pour votre contribution et participation.

Rasta Bomboclat

Tu veux récupérer les deux valeurs (Débit et Crédit), si c'est le cas, il te faut 2 tableaux ou alors, concaténer les deux valeurs dans la même cellule mais dans ce cas, il te sera plus difficile d'effectuer des calculs !

dans l'hypothèse où tu veux récupérer les deux valeurs, elles seront dans deux tableaux différents :

Code:

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
Sub Test()
 
    Dim Plage As Range
    Dim Cel As Range
    Dim TblDebit()
    Dim TblCredit()
    Dim TblDonnees
    Dim I As Integer
    Dim J As Integer
 
    With Worksheets("Format Initial")
 
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
    'titres des colonnes
    TblDonnees = Array("Donnée_1", "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")
 
    'défini le nombre de lignes du tableau (+ 1 = ligne des titres)
    I = Application.CountIf(Plage, "Total_Données") + 1
 
    'les bornes étant connues, dimensionne les tableaux
    ReDim TblDebit(1 To I, 1 To UBound(TblDonnees) + 1)
    ReDim TblCredit(1 To I, 1 To UBound(TblDonnees) + 1)
 
    'rempli la première ligne de chaque tableau (les titres)
    For I = 1 To UBound(TblDonnees) + 1: TblDebit(1, I) = TblDonnees(I - 1): Next I
    For I = 1 To UBound(TblDonnees) + 1: TblCredit(1, I) = TblDonnees(I - 1): Next I
 
    'évite la ligne des titres
    I = 2
 
    For Each Cel In Plage
 
        If Cel.Value <> "Total_Données" Then
 
            'récupère la valeur de la cellule en colonne B (débit) et C (crédit)
            J = Application.Match(Cel.Value, TblDonnees, 0) 'pour positionner les valeurs dans les tableaux
            TblDebit(I, J) = Cel.Offset(, 1).Value
            TblCredit(I, J) = IIf(J = 1, Cel.Offset(, 1).Value, Cel.Offset(, 2).Value)
 
        Else
 
            'ligne suivante
            I = I + 1
 
        End If
 
    Next Cel
 
    'colle le tableau dans la feuille
    With Worksheets("Feuil1") '"Format Final")
 
        .Cells(1, 1).Value = "Tableau Débit"
        .Range(.Cells(2, 1), .Cells(UBound(TblDebit, 1) + 1, UBound(TblDebit, 2))).Value = TblDebit
 
        .Cells(UBound(TblDebit, 1) + 2, 1).Value = "Tableau Crédit"
        .Range(.Cells(UBound(TblCredit, 1) + 3, 1), .Cells(UBound(TblCredit, 1) * 2 + 2, UBound(TblCredit, 2))).Value = TblCredit
 
    End With
 
End Sub

21/12/2015, 12h22
RastaBomboclat

Merci Theze pour ton retour rapide et aussi ton code.
Je le teste tout de suite.

Entretemps, je voulais rappeler que le but pour moi est d’obtenir dans le format que j’utilise, les infos reçu d’un autre département. Il me les envois en brut comme dans la feuille « Format Initial », et moi je voudrai les mettre dans le format que j’utilise et ainsi terminer mon travail. Sauf que quand les données font plus de 5000 ligne, les faire une à une n’est pas du tout pratique. Donc pour moi Il ne suffit que je puis transposer le fichier (Format Initial) que je reçois de mon collègue dans mon format (Format Final), et pour le reste je pourrai facilement me débrouiller.

Il y a des Données (Donnée_1 ; Donnée_2 ; Donnée_3 ; …) qui sont toujours au débit et d’autres (Donnée_10, Donnée_11 ; Donnée_12 ; …) qui sont toujours au Crédit. Si je les identifiais une a une, peut-être que ça simplifierai les choses ?

• Débit (Donnée_1 à Donnée_9)
• Crédit (Donnée_10 à Donnée_15)

Merci à tout le monde pour la contribution et participation.

Rasta Bomboclat
21/12/2015, 13h06
Theze

Citation:

Il y a des Données (Donnée_1 ; Donnée_2 ; Donnée_3 ; …) qui sont toujours au débit et d’autres (Donnée_10, Donnée_11 ; Donnée_12 ; …) qui sont toujours au Crédit. Si je les identifiais une a une, peut-être que ça simplifierai les choses ?

A moins que tu ais un compilateur devin, je pense qu'il serait préférable des les identifier les unes par rapport aux autres !
21/12/2015, 13h41
RastaBomboclat

1 pièce(s) jointe(s)

Merci Theze, il fonctionne bien, et en principe je devrais me caller sur ce dernier code, et mettre une petite formule Excel pour regrouper les deux tableaux en un seul, puisque le plus gros a été fait. Mais je décelé une omission de ma part. Je l'explique plus bas.

P.S.:
Dans le code sur la ligne 56, il y a eu une erreur que j’ai corrigée.

Code:

With Worksheets("Feuil1") '"Format Final")

Je l’ai remplacer d’abord par:

Code:

With Worksheets("1") '"Format Final")

Ce qui m’a mis la réponse attend sur ma feuille “Format Initial”, puis j’ai corrigé avec

Code:

With Worksheets("2") '"Format Final")

Ce qui m’a résolu la petite erreur.

Quand j'ai essayer finalment de l'appliquer sur mon fichier de travail, une erreur a été generé.
:arf: Je viens de me rendre compte que la « Donnée_1 » est variable, puisqu’étant un code employé (tel que DA1234 ou LU1234). C’est le seul problème qui reste. Comme les code employés changent pour chaque employé, on ne peut plus declarer dans le TblDonnes "Données_1". Vraiment désolé pour ce gros oubli. Il y a-t-il moyen d'y remedier :wow: ?

j'ai joint le fichier ci-dessous.

Merci à tout le monde pour la contribution et participation.

Rasta Bomboclat
22/12/2015, 17h05
RastaBomboclat

Bonjour Theze,
Bonjour la communauté,

Il y a-t-il quelqu’un qui a pu trouver une solution à mon problème ?
Le problème est presque résolu, il ne reste plus qu’à trouver comment insérer la donnée variable dans le tableau.

Merci d’avance toute la communauté.

Rasta Bomboclat.

Bonjour,

Le problème vient du fait que tu ne donne pas toutes les infos dès le début alors on passe du temps pour te donner une solution qu'il faut ensuite reprendre de fond en combles car arrive au compte gouttes d'autres infos !
Tu dis que la valeur "Donnée_1" est variable donc, comment veux-tu qu'elle apparaisse, concaténée au nom car sur un seul tableau, elle ne peut pas se trouver en entête de colonne. Ou alors, dans un champ supplémentaire où l'entête de colonne reste "Donnée_1" pour les nom et "Code" ou Donnée_0" pour le code employés !

Je t'ai pondu un nouveau code regardes le résultat. J'ai rajouté un champ nommé "Donnée_0" qui contient le code employé, le champ "Donnée_1" le nom et j'ai modifié pour récupérer les débits et crédits. Les crédits sont récupérés si le champ "Débit" est égal à 0 :

Code:

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Sub Test()
 
    Dim Plage As Range
    Dim Cel As Range
    Dim TblDebit()
    Dim TblDonnees
    Dim I As Integer
    Dim J As Integer
 
    With Worksheets("Format Initial")
 
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
    'titres des colonnes
    TblDonnees = Array("Donnée_0", "Donnée_1", "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")
 
    'défini le nombre de lignes du tableau (+ 1 = ligne des titres)
    I = Application.CountIf(Plage, "Total_Données") + 1
 
    'les bornes étant connues, dimensionne le tableau
    ReDim TblDebit(1 To I, 1 To UBound(TblDonnees) + 1)
 
    'rempli la première ligne de chaque tableau (les titres)
    For I = 1 To UBound(TblDonnees) + 1
 
        TblDebit(1, I) = TblDonnees(I - 1)
 
    Next I
 
    'évite la ligne des titres
    I = 2
 
    For Each Cel In Plage
 
        If Cel.Value <> "Total_Données" Then
 
            'récupère la valeur de la cellule en colonne B (débit) et C (crédit)...
 
            'pour positionner les valeurs dans le tableau.
            On Error Resume Next
            J = Application.Match(Cel.Value, TblDonnees, 0)
 
            'Une erreur est générée si la valeur n'est pas dans le tableau
            If Err.Number <> 0 Then
 
                J = 1
                TblDebit(I, 1) = Cel.Value
                TblDebit(I, 2) = Cel.Offset(, 1).Value
 
             Else 'si pas d'erreur
 
                'si la valeur est zéro, ce n'est pas un débit mais un crédit
                'alors, récupère la valeur du crédit dans la colonne C
                If Cel.Offset(, 1).Value = 0 Then
 
                    TblDebit(I, J) = Cel.Offset(, 2).Value
 
                Else
 
                    TblDebit(I, J) = Cel.Offset(, 1).Value
 
                End If
 
            End If
 
            'annule le gestionnaire
            On Error GoTo 0
 
        Else
 
            'ligne suivante
            I = I + 1
 
        End If
 
    Next Cel
 
    'colle le tableau dans la feuille
    With Worksheets("Format Final")
 
        .Range(.Cells(1, 1), .Cells(UBound(TblDebit, 1), UBound(TblDebit, 2))).Value = TblDebit
 
    End With
 
End Sub

23/12/2015, 12h00
RastaBomboclat

Theze,
Ta question a presque résolu mon problème. Tu as bien raison, et après avoir vu, où et comment placer cette valeur de Donnée_1, avec mes collègues nous avons décider d’utiliser cette valeur comme valeur fixe qui pourra facilement être retrouvé avec un vlookup dans la feuille Format Final(avec toutes les infos qu’il y aura, se sera du tic au tac).
Je vais terminer mes testes avec des infos plus volumineuse (1000 lignes), avant de revenir valider en cliquant sur Résolu.
Merci encore de m’avoir éclairé.

Theze,

Je te répondais pendant que tu me renvoyais un nouveau code. Je ne l’avais pas vue. Merci. Je le teste tout de suite et reviens aussitôt te dire quoi.

Rasta Bomboclat

Re bonjour Theze.

Je voulais demander encore une petite chose.
Non, je blague. je suis très content. C'est vraiment Noël! Joyeux Noël a toi et toute la communauté de DEVELOPPEZ.NET

Merci beaucoup pour ta patience et pour ton code, surtout ce dernier, il fonctionne a Merveille!!! Trop cool

Cas RÉSOLU!

Rasta Bomboclat

Bonsoir Theze, RastaBomboclat, le forum :)

Dans ton cas, on pourrait employer la méthode ColumnDifferences sur la colonne A et parcourir ainsi chaque zone.

Sinon ici, j'utilise la méthode SpecialCells sur la colonne B :
Restitution en Feuil1.

Code:

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
Option Explicit
 
Sub test()
Dim myAreas As Areas, r As Range, i As Long, t As Long, x, y
Dim tablo
    Application.ScreenUpdating = False
    ReDim tablo(1 To 1)
    Set myAreas = Sheets("Format Initial").Columns(2).SpecialCells(2, 1).Areas
    With Sheets("Feuil1")
        For i = 1 To myAreas.Count
            .Cells(i + 1, 1).Value = myAreas(i).Cells(0).Offset(, -1).Value
            .Cells(i + 1, 2).Value = myAreas(i).Cells(0).Value
            t = 2
            For Each r In myAreas(i)
                y = Application.Match(r.Offset(, -1).Value, tablo, 0)
                If IsError(y) Then
                    t = t + 1
                    .Cells(1, t).Value = r.Offset(, -1).Value
                    ReDim Preserve tablo(1 To t)
                    tablo(t) = r.Offset(, -1).Value
                    y = t
                End If
                If r.Offset(, 1).Value <> 0 Then
                    .Cells(i + 1, y).Value = r.Offset(, 1).Value
                Else
                    .Cells(i + 1, y).Value = r.Value
                End If
            Next
        Next
        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

klin89

Bonsoir et bon Noël à tous :D

Avec la méthode ColumnDifferences, c'est plus judicieux.

Code:

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

Bonne soirée à tous
klin89

Bonsoir Klin89,

Merci pour ton code, mieux vaut tard que jamais, dit-on. Et en plus c'est une nouvelle possibilité, que j'ai vraiment envie de tester, même suis le code de Theze fonctionne bien, "l'abondance de bien ne nuis pas..." ;)

Merci à toute la communauté pour toute l'aide et le soutient.

Rasta Bomboclat

Bonjour Klin89,

Ton code fonction à merveille, avec les couleurs et les autres format, je n'y avais pas enconre pensé, tellement j'étais sous préssions pour faire fonctionner ma macro.

Grand :merci: à vous deux THEZE et KLIN89, qui m'avez fourni de le resultat que je cherchais. Merci encore.

La je vais ouvrir une nouvelle discution pour demander comment créer un bouton dans la barre de menu. En effet toutes les solutions que j'ai pu trouver sur msdn.microsoft.com ne fontionne pas.

Rasta Bomboclat

Bonjour à tous,

Je reviens avec le code que THEZE et KLIN89 m’ont aidé à avoir et je souhaiterai y apporter quelques modification pour que la macro puisse organiser le tableau.

Au fait, le code fonctionne à merveille, mais il m’a été demandé d’organiser le tableau généré en débit et crédit. C’est-à-dire, que dans le tableau, après les deux première colonnes (de Noms et Code Fonctionnaire) viennent les colonnes des données de débit, et après viendront les colonnes des données de crédit. Cela permettra à ce que l'on puisse facilement rajouter deux nouvelles colonnes à la fin du tableau (Total Débit et Total Crédit).

Ma difficulté se trouve au niveau entre les lignes 49 et 86. Mais si le reste du code peut etre optimiser, merci encore…

Merci à vous tous qui contribuez.

Rasta Bomboclat

voici le code:

Code:

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
Option Explicit
 
Sub PayrollConvert()
Dim myAreas As Areas, I As Long, J As Long, t As Long, y, c
Dim r As Integer, s As Integer
Dim tablo, DerniereLigne
 
'Nommer la feuil premiere feuil
    Worksheets(1).Name = "Format Initial"
 
'Formate la feuille en ajustant la taille des colonne, en mettant un filtre de colonne et un freeze pane
    Columns("A:D").Select
    Selection.EntireColumn.AutoFit
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Range("A1:C1").Select
    Selection.AutoFilter
    Range("A1").Select
 
'Crée une nouvelle feuil en dernière position et la nomme, puis retourne à la première feuil
    On Error Resume Next
    Err = 0
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Format Final"
    If Err <> 0 Then
        Application.DisplayAlerts = False
        ActiveSheet.Delete        'détruit la feuille créée
        Application.DisplayAlerts = True
        MsgBox Application.UserName & "," & vbCr & "A folha" & vbCr & "Format Final" & vbCr & "já exist. Deves recomeçar o processo." & vbCr & "Lamentamos", vbCritical, "Interupção do processo!"
        Exit Sub
    End If
 
'Effacer les lignes des cellules vide de la colonne A.
    Worksheets(1).Select
    For Each c In Worksheets(1).Range("A1:A" & Range("A65356").End(xlUp).Row)
        If c = "" Then c.EntireRow.Delete
    Next c
'Effacer les ligne de l'About System
    DerniereLigne = Worksheets(1).UsedRange.Rows.Count
        For r = DerniereLigne To 1 Step -1
            If Cells(r, 1) Like "*© PRIMAVERA*" Then Rows(r).Delete
        Next r
'
        For s = DerniereLigne To 1 Step -1
            If Cells(s, 1) Like "*global em*" Then Rows(s).Delete
        Next s
 
'Début du processus de conversion et transposition
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 Funcionário", lookat:=xlWhole)).Select
            Set myAreas = .ColumnDifferences(.Find("Total Funcionário", lookat:=xlWhole)).Areas
            On Error GoTo 0
        End With
    End With
    If myAreas Is Nothing Then Exit Sub
    'Restitution
    With Sheets("Format Final")
        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)
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
 
End With
 
'Formatage des cellules.
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Nome do Funcionario"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Cgo.Funcionario"
    Range("C1").Select
    Selection.Copy
    Range("A1:B1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("C:C").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Style = "Comma"
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.EntireColumn.AutoFit
    Columns("B:B").Select
    Columns("B:B").EntireColumn.AutoFit
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Range("A1").Select
 
'Message de confirmation de processus réussi.
    If MsgBox(Application.UserName & "," & vbCr & "A converção foi feita com successo." & vbCr & "Parabenz!" & vbCr & vbCr & "Deseja ir para a folha FORMAT FINAL ?", vbInformation + vbYesNo) = vbYes Then
        Worksheets("Format Final").Activate
        Worksheets("Format Final").Range("A1").Select
 
    Else: Worksheets("Format Initial").Activate
        Worksheets("Format Initial").Range("A1").Select
 
    End If
 
Application.ScreenUpdating = True
 
'Fin et sortie de la macro.
End Sub

Bonjour,

Avec deux tableaux (Crédits et Débits) et une mise en forme (sera supprimée et recréé à chaque lancement) :

Code:

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
 
Sub Test()
 
    Dim Plage As Range
    Dim Cel As Range
    Dim TblDebit()
    Dim TblCredit()
    Dim TblDonnees
    Dim I As Integer
    Dim J As Integer
    Dim Lgn As Long
 
    'vide la feuille de toutes données et supprime toutes mises en forme
    With Worksheets("Format Final").Cells
 
        .Clear
 
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
 
        .UnMerge
 
        .FormatConditions.Delete
 
        .Font.Bold = False
 
    End With
 
    'défini la plage
    With Worksheets("Format Initial")
 
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
    'titres des colonnes
    TblDonnees = Array("Code", "Nom", "Total", "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")
 
    'défini le nombre de lignes du tableau (+ 1 = ligne des titres)
    I = Application.CountIf(Plage, "Total_Données") + 1
 
    'les bornes étant connues, dimensionne les tableaux
    ReDim TblDebit(1 To I, 1 To UBound(TblDonnees) + 1)
    ReDim TblCredit(1 To I, 1 To UBound(TblDonnees) + 1)
 
    'rempli la première ligne de chaque tableau (les titres)
    For I = 1 To UBound(TblDonnees) + 1
 
        Select Case TblDonnees(I - 1)
 
            Case "Total"
                TblDebit(1, I) = "Total Débit"
                TblCredit(1, I) = "Total Crédit"
 
            Case Else
                TblDebit(1, I) = TblDonnees(I - 1)
                TblCredit(1, I) = TblDonnees(I - 1)
 
        End Select
 
    Next I
 
    'évite la ligne des titres
    I = 2
 
    For Each Cel In Plage
 
        If Cel.Value <> "Total_Données" Then
 
            'récupère la valeur de la cellule en colonne B (débit) et C (crédit)
            On Error Resume Next
            J = Application.Match(Cel.Value, TblDonnees, 0) 'pour positionner les valeurs dans les tableaux
 
            If Err.Number <> 0 Then
 
                J = 1
                TblDebit(I, 1) = Cel.Value
                TblDebit(I, 2) = Cel.Offset(, 1).Value
 
                TblCredit(I, 1) = Cel.Value
                TblCredit(I, 2) = Cel.Offset(, 1).Value
 
             Else
 
                'si la valeur est zéro, ce n'est pas un débit mais un crédit
                'alors, récupère la valeur du crédit dans la colonne C
                If Cel.Offset(, 1).Value = 0 Then
 
                    TblDebit(I, J) = Cel.Offset(, 2).Value
 
                Else
 
                    TblCredit(I, J) = Cel.Offset(, 1).Value
 
                End If
 
            End If
 
            On Error GoTo 0
 
        Else
 
            'ligne suivante
            I = I + 1
 
        End If
 
    Next Cel
 
    'récupère le nombre de lignes
    I = Application.CountIf(Plage, "Total_Données")
 
    'colle le tableau dans la feuille
    With Worksheets("Format Final")
 
'************************************************
'*           Tableau des débits                 *
'************************************************
 
        'fusionne
        .Range(.Cells(2, 1), Cells(2, UBound(TblDebit, 2))).Merge
 
        'en défini la valeur et formate
        With .Cells(2, 1)
 
            .Value = "TABLEAU DEBIT"
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Bold = True
            .Interior.Color = 8564980
 
        End With
 
        'les titres en gras et fond en couleur
        With .Range(.Cells(3, 1), .Cells(3, UBound(TblDebit, 2)))
 
            .Font.Bold = True
            .Interior.Color = 49407
 
        End With
 
        'cadrillage
        With .Range(.Cells(2, 1), .Cells(UBound(TblDebit, 1) + 2, UBound(TblDebit, 2)))
 
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
 
        End With
 
        'MFC pour colorer une ligne non l'autre
        With .Range(.Cells(3, 1), .Cells(UBound(TblDebit, 1) + 2, UBound(TblDebit, 2)))
 
            .FormatConditions.Add 2, , "=MOD(LIGNE();2)=0"
            .FormatConditions(1).Interior.Color = 10086399
 
        End With
 
        'colle les valeurs
        .Range(.Cells(3, 1), .Cells(UBound(TblDebit, 1) + 2, UBound(TblDebit, 2))).Value = TblDebit
 
        'ajoute les formule de sommage
        .Cells(4, 3).Formula = "=SUM(D4:Q4)": .Cells(4, 3).AutoFill .Range(.Cells(4, 3), .Cells(I + 3, 3))
 
'************************************************
'*          Tableau des crédits                 *
'************************************************
 
        Lgn = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
 
        .Range(.Cells(Lgn, 1), Cells(Lgn, UBound(TblDebit, 2))).Merge
 
        With .Cells(Lgn, 1)
 
            .Value = "TABLEAU CREDIT"
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Bold = True
            .Interior.Color = 8564980
 
        End With
 
        With .Range(.Cells(Lgn + 1, 1), .Cells(Lgn + 1, UBound(TblCredit, 2)))
 
            .Font.Bold = True
            .Interior.Color = 49407
 
        End With
 
        With .Range(.Cells(Lgn + 1, 1), .Cells(UBound(TblCredit, 1) + Lgn, UBound(TblCredit, 2)))
 
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
 
        End With
 
        With .Range(.Cells(Lgn + 2, 1), .Cells(UBound(TblCredit, 1) + Lgn, UBound(TblCredit, 2)))
 
            .FormatConditions.Add 2, , "=MOD(LIGNE();2)=0"
            .FormatConditions(1).Interior.Color = 10086399
 
        End With
 
 
        .Range(.Cells(Lgn + 1, 1), .Cells(UBound(TblCredit, 1) + Lgn, UBound(TblCredit, 2))).Value = TblCredit
 
        .Cells(Lgn + 2, 3).Formula = "=SUM(D" & Lgn + 2 & ":Q" & Lgn + 2 & ")": .Cells(Lgn + 2, 3).AutoFill .Range(.Cells(Lgn + 2, 3), .Cells(Lgn + I + 1, 3))
 
    End With
 
End Sub

03/01/2016, 16h08
RastaBomboclat

1 pièce(s) jointe(s)

Illustration

Bonjour,

Je n'annexe le fichier pour mieux illustrer ce que je souhaite faire (obtenir).

Merci à tous ;)

Bonjour, bonjour !

D'après le classeur joint dans le post précédent :

Code:

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
Sub Demo1()
                                        Const DN1 = "Donnée_1"
    With Feuil1.UsedRange
        L& = Application.CountIf(.Columns(1), DN1)
        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)
        Select Case VA(R, 1)
        Case DN1:  N& = N& + 1:    TR(N, 1) = DN1:       TR(N, 2) = VA(R, 2)
        Case "Total_Données":  TR(N, C - 1) = VA(R, 3):  TR(N, C) = -VA(R, 4)
        Case Else
                         V = Application.Match(VA(R, 1), NC, 0)
            If IsNumeric(V) Then TR(N, V) = VA(R, 2) - VA(R, 3)
        End Select
    Next
    With Feuil2.[A2].Resize(L, C)
        .NumberFormat = "[Blue]* #,##0.00 ;[Red]* #,##0.00 ;; @ "
               .Value = TR
    End With
End Sub

______________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

______________________________________________________________________________________________________

Je suis Paris, Charlie, …

04/01/2016, 16h16
RastaBomboclat

Désolé Theze, je n'avais pas vu ton poste.
Je crois que c'est arrivé pendant que j'écrivais :) . Merci beaucoup. je vais le tester.

Merci aussi à toi Marc-L,
Je vais tester ton code.

A toute la communauté Développez.net Bonne Année!:lahola:

Bonjour,

Un code qui donne ce que tu demande :

Code:

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
 
Sub Test()
 
    Dim Plage As Range
    Dim Cel As Range
    Dim TblDebit()
    Dim TblCredit()
    Dim TblDonneesCredit
    Dim TblDonneesDebit
    Dim I As Integer
    Dim J As Integer
    Dim Col As Integer
 
    'défini la plage
    With Worksheets("Format Initial")
 
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
    'titres des colonnes
    TblDonneesDebit = Array("", "", "Donnée_2", "Donnée_3", "Donnée_4", "Donnée_5", _
                            "Donnée_6", "Donnée_7", "Donnée_8")
 
    TblDonneesCredit = Array("Donnée_9", "Donnée_10", "Donnée_11", "Donnée_12", _
                             "Donnée_13", "Donnée_14", "Donnée_15")
 
    'défini le nombre de lignes du tableau (+ 1 = ligne des titres)
    I = Application.CountIf(Plage, "Total_Données") + 1
 
    'les bornes étant connues, dimensionne les tableaux
    ReDim TblDebit(1 To I, 1 To UBound(TblDonneesDebit) + 1)
    ReDim TblCredit(1 To I, 1 To UBound(TblDonneesCredit) + 1)
 
    'rempli la première ligne de chaque tableau (les titres)
    For I = 1 To UBound(TblDonneesDebit) + 1: TblDebit(1, I) = TblDonneesDebit(I - 1): Next I
    For I = 1 To UBound(TblDonneesCredit) + 1: TblCredit(1, I) = TblDonneesCredit(I - 1): Next I
 
    'évite la ligne des titres
    I = 2
 
    For Each Cel In Plage
 
        If Cel.Value <> "Total_Données" Then
 
            Select Case Cel.Value
 
                Case "Donnée_1"
                    TblDebit(I, 1) = Cel.Value
                    TblDebit(I, 2) = Cel.Offset(, 1).Value
 
                Case "Donnée_2", "Donnée_3", "Donnée_4", "Donnée_5", "Donnée_6", "Donnée_7", "Donnée_8"
                    J = Application.Match(Cel.Value, TblDonneesDebit, 0)
                    TblDebit(I, J) = Cel.Offset(, 1).Value
 
                Case "Donnée_9", "Donnée_10", "Donnée_11", "Donnée_12", "Donnée_13", "Donnée_14", "Donnée_15"
                    J = Application.Match(Cel.Value, TblDonneesCredit, 0)
                    TblCredit(I, J) = Cel.Offset(, 2).Value
 
            End Select
 
        Else
 
            'ligne suivante
            I = I + 1
 
        End If
 
    Next Cel
 
    With Worksheets("Format Final")
 
        'supprime tout formatage et valeurs
        With .Cells
 
            .Clear
            .ClearFormats
            .Font.ColorIndex = 0
            .Font.Bold = False
 
            .Borders(xlEdgeLeft).LineStyle = xlNone
            .Borders(xlEdgeTop).LineStyle = xlNone
            .Borders(xlEdgeBottom).LineStyle = xlNone
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
 
            .FormatConditions.Delete
 
        End With
 
        'colle les valeurs, formate les nombres et colore la fonte en bleu
        .Range(.Cells(1, 1), .Cells(UBound(TblDebit, 1), UBound(TblDebit, 2))).Value = TblDebit
        .Range(.Cells(1, 1), .Cells(UBound(TblDebit, 1), UBound(TblDebit, 2))).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
        .Range(.Cells(1, 3), .Cells(UBound(TblDebit, 1), UBound(TblDebit, 2))).Font.ColorIndex = 5
 
        Col = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
 
        'double traits verticaux en séparation des tableaux
        .Range(.Cells(1, Col - 1), .Cells(UBound(TblDebit, 1), Col - 1)).Borders(xlEdgeRight).LineStyle = xlDouble
 
        'colle les valeurs, formate les nombres et colore la fonte en bleu
        .Range(.Cells(1, Col), .Cells(UBound(TblCredit, 1), UBound(TblCredit, 2) + Col - 1)).Value = TblCredit
        .Range(.Cells(1, Col), .Cells(UBound(TblCredit, 1), UBound(TblCredit, 2) + Col - 1)).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
        .Range(.Cells(1, Col), .Cells(UBound(TblCredit, 1), UBound(TblCredit, 2) + Col - 1)).Font.ColorIndex = 3
 
        'double traits verticaux en séparation des tableaux et colonnes de sommage
        Col = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        .Range(.Cells(1, Col - 1), .Cells(UBound(TblDebit, 1), Col - 1)).Borders(xlEdgeRight).LineStyle = xlDouble
 
        'titres de deux colonnes
        .Cells(1, Col).Value = "Total_Debit"
        .Cells(1, Col + 1).Value = "Total_Crédit"
 
        'formule de sommage
        .Cells(2, Col).Formula = "=SUM(C2:I2)": .Cells(2, Col).AutoFill .Range(.Cells(2, Col), .Cells(UBound(TblDebit, 2) - 1, Col))
        .Cells(2, Col + 1).Formula = "=SUM(J2:P2)": .Cells(2, Col + 1).AutoFill .Range(.Cells(2, Col + 1), .Cells(UBound(TblCredit, 2) + 1, Col + 1))
 
        'coloration des fontes
        .Range(.Cells(2, Col), .Cells(UBound(TblDebit, 2) - 1, Col)).Font.ColorIndex = 5
        .Range(.Cells(2, Col + 1), .Cells(UBound(TblCredit, 2) + 1, Col + 1)).Font.ColorIndex = 3
 
        'mise en gras de la ligne d'entêtes
        .Range(.Cells(1, 3), .Cells(1, Col + 1)).Font.Bold = True
 
        'cadrillage
        With .Range(.Cells(1, 1), .Cells(UBound(TblDebit, 1), Col + 1))
 
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
 
        End With
 
        'double traits verticaux en fin de tableau
        .Range(.Cells(1, Col + 1), .Cells(UBound(TblDebit, 1), Col + 1)).Borders(xlEdgeRight).LineStyle = xlDouble
 
        With .Range(.Cells(2, 1), .Cells(UBound(TblCredit, 1), Col + 1))
 
            .FormatConditions.Add 2, , "=MOD(LIGNE();2)=0"
            .FormatConditions(1).Interior.Color = 10086399
 
        End With
 
    End With
 
End Sub

Dans le cas où "Donnée_1" serait le en fait code (style LUA1234 comme indiqué dans un classeur précédemment posté), remplace le bloc Select Case par celui-ci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
            Select Case Cel.Value
 
                Case "Donnée_2", "Donnée_3", "Donnée_4", "Donnée_5", "Donnée_6", "Donnée_7", "Donnée_8"
                    J = Application.Match(Cel.Value, TblDonneesDebit, 0)
                    TblDebit(I, J) = Cel.Offset(, 1).Value
 
                Case "Donnée_9", "Donnée_10", "Donnée_11", "Donnée_12", "Donnée_13", "Donnée_14", "Donnée_15"
                    J = Application.Match(Cel.Value, TblDonneesCredit, 0)
                    TblCredit(I, J) = Cel.Offset(, 2).Value
 
                Case Else
                    TblDebit(I, 1) = Cel.Value
                    TblDebit(I, 2) = Cel.Offset(, 1).Value
 
            End Select

05/01/2016, 19h05
RastaBomboclat

Cas Résolu!

Theze,

Ton code fonctionne à merveille. Il n'y a plus rien à y ajouter. Complet!

Merci :merci::resolu:Theze. et merci a toute la communauté developpez.net.
05/01/2016, 19h13
Marc-L

Mon code du post #15 fonctionne bien avec le classeur joint dans le post #14, a-t-il été testé au moins ? …
05/01/2016, 19h23
RastaBomboclat

Oui Marc-L,

Merci pour ton code. je crois que j'y avais répondu mais je ne sais pas comment et pourquoi, le post n'apparait pas ici mais dans un autre "module" en solo, où je vous ai remercier toi et Theze, pour vos code.

Je ne l'ai plus utilisé pour le cas de mon travaille parce que je me suis senti un peu géner de dire que les "Donnée_1" n'était pas une constante mais plutôt une variable. C'est en fait le Code_Employé. Il y en a autant qu'il y a d'employés. Je l'avais dis dans un post plus haut. Je ne voulais pas trop demander:(
Mais merci beaucoup pour votre soutient et assistance.:plusser:

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:

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 :plusser: pour chaque message ayant aidé …

06/01/2016, 12h28
RastaBomboclat

1 pièce(s) jointe(s)
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:

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.Pièce jointe 197167
06/01/2016, 12h52
Marc-L

Citation:

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 ?!
06/01/2016, 13h42
RastaBomboclat

2 pièce(s) jointe(s)

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.
06/01/2016, 14h17
Theze

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.
06/01/2016, 14h45
RastaBomboclat

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.
06/01/2016, 14h51
Theze

Mais maintenant, tout fonctionne comme tu veux quel que soit le code utilisé ?
06/01/2016, 14h53
Marc-L

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é :

http://perso.numericable.fr/mpl/pic/RastaDemo1a.gif

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 !

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:ccool::plusser:

Code:

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

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:

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 :plusser: pour chaque message ayant aidé …

07/01/2016, 15h39
RastaBomboclat

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

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 :scarymov:

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

P.S.:
Cette foi c'est vraiment :resolu: pour de vrai. :wink:

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

Code:

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" …

07/01/2016, 21h52
RastaBomboclat

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:chin:
07/01/2016, 23h03
Marc-L

Merci !

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

______________________________________________________________________________________________________
Je suis Charlie, …

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:

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 …

Si tu repasses RastaBomboclat

Bonsoir à tous, :)

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

Code:

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