Discussion :

[zoumzoum59]

Bonjour a tous,

Je reviens avec une continuité d'une ancienne discussion qui date de prés d'un an, ou Eric KERGRESSE m'avait donné un fier coup de main pour resoudre mon problème, cependant je reviens avec ce projet car mon besoin sur la restitution final a un peu changé.
La discussion était la suivante: https://www.developpez.net/forums/d1...l/aide-boucle/

J'ai bien essayé de regarder de mon coté, mais déjà dans l'analyse du code c'est pas simple malgré que j'ai modifier certaines chose depuis le code du départ.
donc si quelqu'un peut me donner la direction a prendre ça serait génial.
Mon besoin auparavant était de faire le cumul dans une feuille source de dimension correspondant a certaines références qui ce trouvait sur plusieurs feuilles et dans des colonnes identiques.
Maintenant mon besoin reste quasiment le même mais dans la restitution je voudrais avoir le cumul mais par feuille comme présenté ci dessous:

Avant



Apres


Le code correspondant a ce qui fonctionne actuellement est celui ci:

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
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
Public MaMatrice() As Variant
 
Sub ExtractionCodeSurPlusieursOnglets()
 
    Dim ShCible As Worksheet
    Dim ListeDesOngletsATraiter As Variant
    Dim k As Integer
    Dim i As Integer, j As Integer, l As Integer, Tab_Feuil(), Liste()
  Dim aze
 
 
    For i = 7 To ThisWorkbook.Worksheets.Count
    aze = ActiveWorkbook.Sheets(Sheets(i).Name).Range("N5:Q6500").Value
 
 
        If Sheets(i).Visible And Application.CountA(ActiveWorkbook.Sheets(Sheets(i).Name).Range("N5:Q6500")) <> 0 Then
            ReDim Preserve Tab_Feuil(j)
            Set Tab_Feuil(j) = Sheets(Sheets(i).Name)      '<----- ligne complétée
            j = j + 1
        End If
 
    Next
    Dim lNumElements As Long
 
    lNumElements = UBound(Tab_Feuil) - LBound(Tab_Feuil) + 1
    l = lNumElements - 1
 
 
    Set ShCible = Sheets("Total Chant")
    With ShCible
        .Range(.Cells(1, 1), .Cells(.Rows.Count, 2)).ClearContents
    End With
    ListeDesOngletsATraiter = Tab_Feuil
 
    For k = 0 To l
 
        Extraction_Code ListeDesOngletsATraiter(k)
        RestituerLaMatrice ShCible
 
    Next k
    ' Tri de l'onglet cible....
    Set ShCible = Nothing
 
End Sub
 
Sub Extraction_Code(ByVal FeuilleSource As Worksheet)
 
    Dim MonDico As Object
    Dim C As Range
    Dim DerniereLigne As Long
 
    Dim ListeCle As Variant
    Dim ListeElement As Variant
    Dim i As Integer
    Dim j As Integer
    Dim Tempo1, Tempo2
 
    Set MonDico = CreateObject("Scripting.Dictionary")
 
    With FeuilleSource
        DerniereLigne = .Cells(.Rows.Count, 5).End(xlUp).Row  ' Colonne à adapter
        For Each C In .Range(.Cells(5, 14), .Cells(DerniereLigne, 17))
            If Not MonDico.Exists(C.Value) And C.Value <> "" Then MonDico.Add C.Value, C.Value
        Next C
        'Stop
        ListeCle = MonDico.Keys
        ListeElement = MonDico.Items
 
        ' Tri par ordre alphabétique dans la variable tableau
        '----------------------------------------------------
        For i = 0 To MonDico.Count - 2
            For j = i + 1 To MonDico.Count - 1
                If ListeElement(i) > ListeElement(j) Then
 
                    Tempo1 = ListeCle(j)
                    Tempo2 = ListeElement(j)
 
                    ListeElement(j) = ListeElement(i)
                    ListeCle(j) = ListeCle(i)
 
                    ListeCle(i) = Tempo1
                    ListeElement(i) = Tempo2
 
                End If
            Next j
        Next i
 
        ' Initialisation et remplissage de la matrice
        '--------------------------------------------
 
        ReDim MaMatrice(UBound(ListeCle), 1)
        For i = LBound(ListeCle, 1) To UBound(ListeCle, 1)
            MaMatrice(i, 0) = ListeCle(i)
        Next i
 
        ' Cumul des produits colonne 1 * colonne 2 pour chaque référence
        '---------------------------------------------------------------
        For i = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
            For Each C In .Range(.Cells(1, 14), .Cells(DerniereLigne, 14))
                If C = MaMatrice(i, 0) Then MaMatrice(i, 1) = MaMatrice(i, 1) + (C.Offset(0, 8 - 14) * (C.Offset(0, 9 - 14) + 50)) / 1000
            Next C
 
            For Each C In .Range(.Cells(1, 15), .Cells(DerniereLigne, 15))
                If C = MaMatrice(i, 0) Then MaMatrice(i, 1) = MaMatrice(i, 1) + (C.Offset(0, 8 - 15) * (C.Offset(0, 9 - 15) + 50)) / 1000
            Next C
 
            For Each C In .Range(.Cells(1, 16), .Cells(DerniereLigne, 16))
                If C = MaMatrice(i, 0) Then MaMatrice(i, 1) = MaMatrice(i, 1) + (C.Offset(0, 8 - 16) * (C.Offset(0, 10 - 16) + 50)) / 1000
            Next C
 
            For Each C In .Range(.Cells(1, 17), .Cells(DerniereLigne, 17))
                If C = MaMatrice(i, 0) Then MaMatrice(i, 1) = MaMatrice(i, 1) + (C.Offset(0, 8 - 17) * (C.Offset(0, 10 - 17) + 50)) / 1000
 
            Next C
 
        Next i
 
    End With
 
 
 
    Set MonDico = Nothing
 
End Sub
 
Sub RestituerLaMatrice(ByVal FeuilleCible As Worksheet)
 
    Dim DerniereLigneCible As Long, MonItem As Long
    Dim AireCible As Range, CelluleCible As Range
    Dim ReferenceTrouvee As Boolean
 
    With FeuilleCible
 
        DerniereLigneCible = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set AireCible = .Range(.Cells(1, 1), .Cells(DerniereLigneCible, 1))
 
        For MonItem = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
            ReferenceTrouvee = False
            For Each CelluleCible In AireCible
                If CelluleCible = MaMatrice(MonItem, 0) Then
                    CelluleCible.Offset(0, 1) = CelluleCible.Offset(0, 1) + MaMatrice(MonItem, 1)
                    ReferenceTrouvee = True
                End If
            Next CelluleCible
            If ReferenceTrouvee = False Then
                .Cells(DerniereLigneCible + 1, 1) = MaMatrice(MonItem, 0)
                .Cells(DerniereLigneCible + 1, 2) = MaMatrice(MonItem, 1)
                DerniereLigneCible = DerniereLigneCible + 1
            End If
        Next MonItem
 
        Set AireCible = Nothing
 
    End With
 
End Sub

J'espere avoir été assez clair et que quelqu'un pourra me donner un axe de recherche pour modifier le code, car je pense qu'il va faloir modifier certaine boucle mais je suis un peu perdu.

Merci d'avance