Discussion :

[thojus]

Bonjour,

il se trouve que j'ai un fichier.
Dans la colonne A se trouve des références (qui peuvent être en doublons) et en colonne B,C,D des montants selon 3 catégories différentes (mettons B: pièce, C: moteur, D: hélice)

Je souhaite une macro qui:
- additionne les référence qui sont en doublons dans les colonnes B, C, et/ou D (mettons la référence 12 possède un montant 10e dans B et un plus bas la même référence possède un montant de 12e dans la colonne B; faire en sorte qu'un unique montant 22e soit dans la colonne B)
- Regroupe en une seule ligne une même référence répartie sur plusieurs colonnes
Par exemple la référence 12 a un montant de 22e en B puis plus bas on retrouve cette référence 12 avec un montant de 19 euros en colonne C, faire en sorte que 22e et 19e soit dans leur colonnes respectives en une seule ligne.

Pour ce deuxième point j'ai déjà élaborer quelque chose mais la où ça coince c'est que lorsqu'une même référence est présente plusieurs fois dans la même colonne (par exemple la référence 12 en colonne B a un montant de 10e et plus bas on retrouve la référence 12 pour un montant de 10 euros): il en prends une de manière arbitraire et sans les additionner les unes aux autres, ce qui fausse complètement.

Je vous envoie un excel pour vous montrer ce que je souhaite.
Il faut qu'il parcours l'ensemble du tableau sur la première feuille (tableau dont la longueur est variable), additionne les valeurs d'une même référence et d'une même colonne et regroupe les valeurs d'une même références mais sur plusieurs colonnes en une seule ligne.

Le code que j'avais jusqu'ici:

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
Option Explicit
 
Sub Regroupe()
Dim J As Long
Dim I As Integer
Dim K As Long
Dim Tablo
 
  Application.ScreenUpdating = False
  Tablo = Application.Transpose(Range(Range("A3"), Cells(4, Cells(3, Columns.Count).End(xlToLeft).Column)))
  For J = 5 To Range("A" & Rows.Count).End(xlUp).Row
    For K = 2 To UBound(Tablo, 2)
      If Range("A" & J) = Tablo(1, K) Then
        For I = 2 To UBound(Tablo)
          If Cells(J, I) <> "" Then Tablo(I, K) = Cells(J, I)
        Next I
        Exit For
      End If
    Next K
    If K > UBound(Tablo, 2) Then
      ReDim Preserve Tablo(1 To UBound(Tablo), 1 To UBound(Tablo, 2) + 1)
      Tablo(1, UBound(Tablo, 2)) = Range("A" & J)
      For I = 2 To UBound(Tablo)
        If Cells(J, I) <> "" Then Tablo(I, K) = Cells(J, I)
      Next I
    End If
  Next J
  With Sheets("Résultat")
    .Cells.ClearContents
    .Range("A1").Resize(UBound(Tablo, 2), UBound(Tablo)) = Application.Transpose(Tablo)
    .Select
  End With
End Sub

Les colonnes vont jusqu'à J et les feuilles n'ont pas le même nom, mais pour vous simplifier j'ai pris un exemple facile. Une fois que j'ai le code basique je suis capable de le reproduire et de l'adapter à ma situation.

Je vous remercie par avance,

Thojus

[Invité]

Bonjour,

Vous pouvez obtenir le même résultat que votre tableau arrivée avec un TCD.

Le fichier joint contient le TCD. Il suffit de mettre tous les champs Pièce, Moteur et Hélice en somme de valeurs.

Si vous souhaitez après, automatiser la génération du fichier tout en supprimant celui existant, le fichier contient les macros ci-dessous dans un module standard de fichier joint. Ces macros sont activées depuis un bouton dans votre feuille Tableau de base.

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
 
Sub GenererTcd(LigneTitre As Long, PremiereColonneFeuille As Long)
 
 
Dim DerniereLigne As Long
Dim DerniereColonne As Long
 
Dim AireDuTcd As Range
 
Dim Pvt As PivotTable
 
Dim Sh As Worksheet
Dim ShEnCours As Worksheet
Dim ShTcd As Worksheet
 
    Set ShEnCours = ActiveSheet
 
    ' Recherche et suppression du Tcd existant
    For Each Sh In Sheets
 
     If Sh.Name = "Tcd Regroupement" Then
 
        Application.DisplayAlerts = False
        Sheets("Tcd Regroupement").Delete
        Application.DisplayAlerts = False
 
    End If
 
    Next Sh
 
    ShEnCours.Activate
 
    DerniereColonne = Cells(LigneTitre, ActiveSheet.Columns.Count).End(xlToLeft).Column
    DerniereLigne = Cells(ActiveSheet.Rows.Count, PremiereColonneFeuille).End(xlUp).Row
 
    ' Recherche de l'aire du tableau
    Set AireDuTcd = Range(Cells(LigneTitre, PremiereColonneFeuille), Cells(DerniereLigne, DerniereColonne))
    AireDuTcd.Select
 
    Sheets.Add
    Set ShTcd = ActiveSheet
 
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        AireDuTcd.Address, Version:=xlPivotTableVersion10). _
        CreatePivotTable TableDestination:=ShTcd.Cells(3, 1), TableName:="Tcd_Regroupement", DefaultVersion:=xlPivotTableVersion10
 
    Cells(3, 1).Select
 
 
    Set Pvt = ShTcd.PivotTables("Tcd_Regroupement")
 
 
    With Pvt.PivotFields("Référence")
        .Orientation = xlRowField
        .Position = 1
    End With
 
    With Pvt
        .AddDataField Pvt.PivotFields("Pièce"), " Pièce", xlSum
        .AddDataField Pvt.PivotFields("Moteur"), " Moteur", xlSum
        .AddDataField Pvt.PivotFields("Hélice"), " Hélice", xlSum
 
        .PivotFields(" Pièce").NumberFormat = "# ##0"
        .PivotFields(" Moteur").NumberFormat = "# ##0"
        .PivotFields(" Hélice").NumberFormat = "# ##0"
 
    End With
 
    With Pvt.DataPivotField
        .Orientation = xlColumnField
        .Position = 1
    End With
 
    ActiveSheet.Name = "Tcd Regroupement"
    ActiveWorkbook.ShowPivotTableFieldList = False
 
    Set Pvt = Nothing
    Set ShTcd = Nothing
    Set AireDuTcd = Nothing
    Set ShEnCours = Nothing
 
 
End Sub

Pour lancer la macro avec ses paramètres toujours le module standard

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

	

	
Code  :
	
Sélectionner tout -
	Visualiser dans une fenêtre à part
	
12345678910111213
Sub LancerLaGenerationDuTCD()
 
Dim LigneDeTitre As Long
Dim ColonneReference As Long
 
 
    Sheets("Tableau de base").Activate
    LigneDeTitre = 1
    ColonneReference = 1
 
    Call GenererTcd(LigneDeTitre, ColonneReference)
 
End Sub

Nb : Je préfère cette méthode de reconstruction de TCD plutôt qu'à leur rafraîchissement. La taille du TCD ne gonfle pas exagérément au fil du temps. Pour la mise en forme du TCD, il faut travailler ensuite avec l'objet Pvt.


Cordialement.

[thojus]

Bonjour,
merci pour cette réponse. J'y jetterais un oeil la semaine prochaine car je me trouve actuellement dans l'impossibilité d'effectuer une manoeuvre VBA avant ce laps de temps.

Je te remercie déjà pour cette réponse et te tiens au courant.

Bonne semaine,

Thojus