Modification de code dû a un besoin different

Version imprimable

2 pièce(s) jointe(s)

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
Pièce jointe 343873

Apres
Pièce jointe 343830

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

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

19/01/2018, 12h45
mjpmjp
bonjour,
dans ton code , il y a une sub :
Sub Extraction_Code(ByVal FeuilleSource As Worksheet)
qui traite à " l'unité " ton problème qui était " global "
avec dans la sub :
Sub ExtractionCodeSurPlusieursOnglets()
qui utilise une boucle " globale " :
Code:

1 2 3 For i = 7 To ThisWorkbook.Worksheets.Count Next
@+JP
19/01/2018, 14h19
Menhir
Ca c'est étrange :
Code:

1 2 For i = 7 To ThisWorkbook.Worksheets.Count aze = ActiveWorkbook.Sheets(Sheets(i).Name).Range("N5:Q6500").Value
Déjà, ActiveWorkbook.Sheets(Sheets(i).Name) peut s'écrire plus simplement Sheets(i).

Ensuite, il est étrange que tu comptes le nombre d'onglets dans ThisWorkbook et que tu appliques l'indice aux onglets de ActiveWorkbook (qui est le parent de ton Sheets(i) ).
A moins que ThisWorkbook et ActiveWorkbook ne soient qu'un seul et même fichier. Mais dans ce cas, je ne vois pas pourquoi tu entretiens la confusion dans ton code en utilisant deux dénominations différentes.
19/01/2018, 14h19
zoumzoum59
Bonjour et merci de me répondre mjpmjp.

Donc si j'arrive a te suivre,je devrais faire quelque chose du genre:

Modifier Sub ExtractionCodeSurPlusieursOnglets() en Sub ExtractionCodeSurUnSeulOnglet()

Puis
Code:

1 2 3 4 5 6 For i = 7 To ThisWorkbook.Worksheets.Count Call ExtractionCodeSurUnSeulOnglet Call RestituerLaMatrice Decaler de une colonne Next

Bonjour Menhir,

Excuse moi pour la confusion que j'ai mis en mettant ce code Déja la ligne:

Code:

1
2
aze = ActiveWorkbook.Sheets(Sheets(i).Name).Range("N5:Q6500").Value

Devrait être effacé je l'avais mis pour faire des test et je ne l'ai pas effacé.:oops:

Ensuite oui le code désigne le même classeur et n'étant pas un pro, je ne me suis pas aperçu que mon manque de rigueur amenait une confusion. Re:oops:

Revoici le code sans cette ligne.

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
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()
 
 
 
    For i = 7 To ThisWorkbook.Worksheets.Count
 
 
 
        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

1 pièce(s) jointe(s)

Bonsoir a tous,

Après quelques jours de travail :pc:, pas en continu certes, je suis arrivé au résultat attendu :D.

Pièce jointe 344624

Par contre je ne suis pas sur que mon code soit hyper clean :?, c'est pour cela que je reposte mon code final pour le proposer à la relecture pour m'indiquer les points qui serait à modifier.

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
Dim i As Integer
Dim DécalColonne As Integer
Dim Compteur As Integer
Public MaMatrice() As Variant
Dim ShCible As Worksheet
 
 
Sub ExtractionCodeSurPlusieursOnglets()
 
    Compteur = 1
    DécalColonne = 1
 
    For i = 7 To ThisWorkbook.Worksheets.Count
        Call ExtractionCodeSurUnOnglet
    Next
 
End Sub
 
Sub ExtractionCodeSurUnOnglet()
 
 
    Dim ListeDesOngletsATraiter As Variant
    Dim k As Integer
    Dim j As Integer, l As Integer, Tab_Feuil(), Liste()
 
 
 
 
    If Sheets(i).Visible Then
        ReDim Preserve Tab_Feuil(j)
        Set Tab_Feuil(j) = Sheets(i)      '<----- ligne complétée
        j = j + 1
 
    End If
 
 
    Dim lNumElements As Long
 
    lNumElements = UBound(Tab_Feuil) - LBound(Tab_Feuil) + 1
 
    l = lNumElements - 1
 
    Set ShCible = Sheets("Total Chant")
    If Compteur = 1 Then
 
        With ShCible
            .Range(.Cells(1, 1), .Cells(.Rows.Count, 20)).ClearContents
        End With
    End If
    Range("A4").Value = "Chants"
    Range("A5").Value = " "
    Compteur = Compteur + 1
    If Application.CountA(Sheets(i).Range("N5:Q6500")) <> 0 Then
        ListeDesOngletsATraiter = Tab_Feuil
 
        For k = 0 To l
 
            Extraction_Code ListeDesOngletsATraiter(k)
            RestituerLaMatrice ShCible
 
        Next k
 
    End If
    ' 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 m 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
 
        ListeCle = MonDico.Keys
        ListeElement = MonDico.Items
 
        ' Tri par ordre alphabétique dans la variable tableau
        '----------------------------------------------------
        For m = 0 To MonDico.Count - 2
            For j = m + 1 To MonDico.Count - 1
                If ListeElement(m) > ListeElement(j) Then
 
                    Tempo1 = ListeCle(j)
                    Tempo2 = ListeElement(j)
 
                    ListeElement(j) = ListeElement(m)
                    ListeCle(j) = ListeCle(m)
 
                    ListeCle(m) = Tempo1
                    ListeElement(m) = Tempo2
 
                End If
            Next j
 
        Next m
 
        ' Initialisation et remplissage de la matrice
        '--------------------------------------------
 
        ReDim MaMatrice(UBound(ListeCle), 1)
        For m = LBound(ListeCle, 1) To UBound(ListeCle, 1)
            MaMatrice(m, 0) = ListeCle(m)
        Next m
 
        ' Cumul des produits colonne 1 * colonne 2 pour chaque référence
        '---------------------------------------------------------------
        For m = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
            For Each C In .Range(.Cells(1, 14), .Cells(DerniereLigne, 14))
                If C = MaMatrice(m, 0) Then MaMatrice(m, 1) = MaMatrice(m, 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(m, 0) Then MaMatrice(m, 1) = MaMatrice(m, 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(m, 0) Then MaMatrice(m, 1) = MaMatrice(m, 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(m, 0) Then MaMatrice(m, 1) = MaMatrice(m, 1) + (C.Offset(0, 8 - 17) * (C.Offset(0, 10 - 17) + 50)) / 1000
 
            Next C
        Next m
 
    End With
 
    Sheets("Total Chant").Cells(4, DécalColonne + 1) = FeuilleSource.Name
 
    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, DécalColonne) = CelluleCible.Offset(0, DécalColonne) + MaMatrice(MonItem, 1)
 
                    ReferenceTrouvee = True
                End If
            Next CelluleCible
            If ReferenceTrouvee = False Then
                .Cells(DerniereLigneCible + 1, 1) = MaMatrice(MonItem, 0)
                .Cells(DerniereLigneCible + 1, DécalColonne + 1) = MaMatrice(MonItem, 1)
 
                DerniereLigneCible = DerniereLigneCible + 1
            End If
        Next MonItem
 
        Set AireCible = Nothing
 
    End With
    DécalColonne = DécalColonne + 1
End Sub

Merci d'avance

23/01/2018, 09h47
Marc-L

Bonjour,

comment sont alimentées la colonne A et la ligne 4 ?

Sinon avec le B-A-BA d'Excel, de simples formules de calculs niveau débutant, à peine 20 lignes de codes sont nécessaires !
Voire même un code est inutile …

___________________________________________________________________________________________________________
Je suis Paris, Egypte, Nigeria, New-York, Mogadicio, Barcelone, London, Manchester, Stockholm, Istanbul, Berlin, Nice, Bruxelles, Charlie, …
23/01/2018, 11h39
zoumzoum59

Bonjour Marc-L,

Je pense que mon besoin est plus compliqué, je ne suis pas expert en formule Excel, mais je vais essayer de t'exposer le fonctionnement de la colonne A et de la ligne 4.

La colonne A est alimenté par plusieurs feuilles (quantité non définie) qui comporte 4 colonnes chacune (de N à Q) ou se retrouve ou pas les références de la colonne A (références identiques pressentent en quantité de 0 à plusieurs centaines).

Quand a la ligne 4 Le termes Chants n'a aucune importance en soit, par contre après ce sont le noms des feuilles présentent a partir de la 7 ème feuille du classeur, mais si une feuille ne comporte aucune référence dans les 4 colonnes, elle ne doit pas apparaitre dans la ligne 4, parce qu’elle ne comporte du coup aucune valeur a calculer en fonction de la référence.
Donc la ligne 4 ne comporte que le nom des feuilles qui ont des références dans les colonnes précitées.

Voila j’espère avoir été suffisamment clair pour que tu comprennes, mais si une solution plus simple existe pourquoi pas.

bonjour,
zoumzoum59 , je te propose quelques "style" de codage qui sont perso et peut être pas forcément valable 8O

tu as bien compris :ccool:
Code:

1 2 3 4 5 6 Sub ExtractionCodeSurPlusieursOnglets() For i = 7 To ThisWorkbook.Worksheets.Count Call ExtractionCodeSurUnOnglet Next End Sub
tu déclares "i" en "portée module" pour pouvoir l'utiliser dans Extraction..UnOnglet
je te propose de transmettre cette valeur avec par exemple :
Code:

1 2 Call ExtractionCodeSurUnOnglet (i)
et de modifier la sub
Code:

1 2 Sub ExtractionCodeSurUnOnglet(ShNum as integer)
de ce fait , cette partie de code
Code:

1 2 3 4 5 6 If Sheets(i).Visible Then ReDim Preserve Tab_Feuil(j) Set Tab_Feuil(j) = Sheets(i) '<----- ligne complétée j = j + 1 End If
pourrait être modifiée ainsi
Code:

1 2 3 4 5 If Sheets(ShNum).Visible Then if ubound(Tab_Feuil) < ShNum then ReDim Preserve Tab_Feuil(ShNum) Set Tab_Feuil(ShNum) = Sheets(ShNum) '<----- ligne complétée End If
a noter ,
je n'ai pas regardé à quoi sert : Set Tab_Feuil(ShNum) = Sheets(ShNum)
je n'ai pas compris : = Sheets(ShNum) ... qui est un object ?

@+JP

23/01/2018, 14h33
zoumzoum59

Bonjour mjpmjp,

Merci pour ton retour sur le code et merci pour ton aiguillage de départ, même si je trouvait a mon gout que tes indications étaient un peu légères, mais je suis quand même arrivé à sortir quelque chose qui fonctionne.
Quand a la partie "Set Tab_Feuil(ShNum) = Sheets(ShNum)" je pense qu'au départ il servait a créer un tableau avec la liste des feuilles à utiliser puisque la procédure était global.
Mais a présent je pense qu'il n'est plus utile de créer un tableau car on boucle les feuilles une à une, mais je n'ai pas réussi a comprendre suffisamment bien le fonctionnement pour le recoder autrement, mais peut être qu'une simple variable suffirait.
23/01/2018, 17h44
Marc-L

Ma question pour l'alimentation de la colonne A et de la ligne 4 : c'est manuel ou par code ?

Oui pour l'aperçu du post #6 tel quel cela a l'air possible sans code via une formule de calculs
et donc utilisable même en VBA (surtout car évitant ainsi ce genre d'usine à gaz du même post !) …
23/01/2018, 18h49
zoumzoum59

Excuse moi Marc-L je n'avais pas compris le sens de ta question, l'alimentation est par code.
Par contre je ne suis pas alaise pour utiliser des formules qui pourrait peut être me donner le même résultat, mais rien que pour créer dans la colonne A la liste des références sans doublons sur les feuilles concerné je suis déjà perdu.
Alors que cela me parait plus simple avec du code.