Bonjour le Forum,
Cette demande est récurrente.
Elle consiste à disposer d’un code qui, à partir d’une colonne appartenant à une feuille de synthèse, crée autant de feuilles que d’occurrences appartenant à celle-ci. Chaque feuille est alimentée par les données extraites de la feuille de synthèse.
Dès lors, 2 problématiques peuvent se poser.
- la liste des occurrences
- l’alimentation des feuilles
La performance des variables tableau n’est certes plus à démontrer. Cette méthode est donc la plus adaptée pour l’alimentation des feuilles.
En ce qui concerne les occurrences, là encore 2 possibilités :
- la méthode collection
- la méthode dictionnaire
Le processus envisagé dans le code proposé se décompose ainsi :
- choix de la colonne par Inputbox, en lettres ou en nombre (conversion par fonction si lettre(s)) (1)
- création de la liste des occurrences par collection ou dictionnaire (triés, pour le fun)
- création des feuilles correspondantes
- alimentation des variables tableau par la méthode Find (Comme d’autres les chauves-souris, « J’aime paaaas » les balayages)
- transposition des données dans la feuille correspondante
(1) Il me pardonnera, je l’espère, j’ai passé outre la remarque – judicieuse par ailleurs – de Didier dans son intéressant tutoriel sur les saisies numériques obligatoires. J’ai donc utilisé la propriété « Isnuméric ».
Je tiens à préciser que je ne suis pas le développeur de toutes les fonctionnalité ici présentées (Merci à Silkyroad, notamment). Mon objectif était de les lier pour aboutir au résultat recherché.
J’espère sincèrement l’utilité de ce développement. Mais je n’en attends pas moins vos remarques constructives qui permettront de l’améliorer.
Par avance, Merci à tous.
Marcel
La fonction de transformation de(s) la(les) lettre(s) colonne en nombre.
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 Option Explicit Option Compare Text Dim numcol As Integer Dim liste As Range '-----------------------------------------------------------------------------------------------------CHOX DE LA COLONNE--------------------------------------------------------------------------------------------------- Sub Crée_Feuiles() Dim dercel As Range Dim choix_col As Variant 'Choix de la colonne de la feuille de Synthèse contenant les occurences choix_col = InputBox("Entrer la colonne où se trouvent les occurences des feuilles à créer." & Chr(10) & "En lettres ou en chiffres (exemple ""AM"" ou 3).", "Colonnes choisie") numcol = IIf(IsNumeric(choix_col), choix_col, Colnuméric(choix_col)) 'Définition de l'adresse contenant toutes les occurences With Sheets("Synth") Set dercel = .Cells(.Rows.Count, numcol).End(xlUp) Set liste = .Range(.Cells(2, numcol), dercel) End With 'Création des Feuilles pour chaque occurence Call Creer_Liste_Feuilles(liste) 'Réinitialisation des variables Set dercel = Nothing Set liste = Nothing End Sub '-----------------------------------------------------------------------------------------------------CREATION LISTE PAR COLLECTION--------------------------------------------------------------------------------------------------- Sub Creer_Liste_Feuilles(Plage As Range) Dim Cell As Range Dim Un As Collection Dim i As Long, j As Long Dim Inverse1, Inverse2, Item Set Un = New Collection On Error Resume Next 'Boucle sur la plage de cellule For Each Cell In Plage 'If Cell <> "" Permet de ne pas prendre en compte les cellules vides 'Un.Add Cell, CStr(Cell) Ajoute le contenu de la cellule dans la collection If Cell <> "" Then Un.Add Cell, CStr(Cell) Next Cell On Error GoTo 0 'Tri de la collection For i = 1 To Un.Count - 1 For j = i + 1 To Un.Count If Un(i) > Un(j) Then Inverse1 = Un(i) Inverse2 = Un(j) Un.Add Inverse1, before:=j Un.Add Inverse2, before:=i Un.Remove i + 1 Un.Remove j + 1 End If Next j Next i 'Boucle sur les éléments de la collection et création de la feuille correspondante. For i = 1 To Un.Count Call Gestion_Feuilles(Un(i)) Next i Set Un = Nothing End Sub '-----------------------------------------------------------------------------------------------------CREATION DE LA FEUILLE SI ELLE N'EXISTE PAS--------------------------------------------------------------------------------------------------- Public Sub Gestion_Feuilles(occurs As String) Dim i As Integer, n As Integer, nbcol As Integer Dim f As Range, celcop As Range Dim firstAddress As String Dim Tablo() As Variant Dim sh As Worksheet Dim existe_feuil As Boolean Application.ScreenUpdating = False 'Ligne de titre With Sheets("Synth") Set celcop = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)) End With 'Nombre de données à alimenter = dimension 1 de la variable Tablo nbcol = celcop.Columns.Count 'Test si la feuille existe existe_feuil = False For Each sh In Worksheets If sh.Name = occurs Then existe_feuil = True Exit For End If Next sh 'Si la feuille n'existe pas, alors création de celle-ci avec nom et titres de colonnes adaptés If existe_feuil = False Then Sheets.Add Type:=xlWorksheet, After:=Sheets(Sheets.Count) celcop.Copy With ActiveSheet .Paste Destination:=.Range("A1") .Name = occurs End With Application.CutCopyMode = False End If 'Alimentation de la variable Tablo With liste Set f = .Find(occurs, LookIn:=xlValues) If Not f Is Nothing Then firstAddress = f.Address Do n = n + 1 ReDim Preserve Tablo(1 To nbcol, 1 To n) 'Toutes les cellules de la ligne alimentent Tablo For i = 1 To nbcol Tablo(i, n) = f.Offset(0, i - numcol) Next i Set f = .FindNext(f) Loop While Not f Is Nothing And f.Address <> firstAddress End If End With 'Alimentation de la feuille With Sheets(occurs) .Range("A2", .Range("A2").Offset(UBound(Tablo, 2) - 1, UBound(Tablo, 1) - 1)).Value = WorksheetFunction.Transpose(Tablo) End With 'Réinitialisation de la variable Tablo Erase Tablo End Sub
(pour ma part, dans module séparé)
Variante dictionnaire (trié)
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 Public Colonne() Public Alphabet() Function Colnuméric(col) 'Stockage de l'alphabet Alphabet = Array("", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z") col = UCase(col) 'Pour eviter les erreurs de case For i = 1 To 26 'Correspondance lettre <=> chiffre (rang) ReDim Preserve Colonne(2, i + 1) Colonne(1, i) = Alphabet(i) Colonne(2, i) = i Next i Select Case Len(col) Case 1 'Cas ou la colonne rentrée est entre A et Z For i = 1 To 26 If Colonne(1, i) = col Then indice = Colonne(2, i) Exit For End If Next 'Cas ou la colonne rentrée comporte 2 lettres Case 2 For i = 1 To 26 If Colonne(1, i) = Left(col, 1) Then indice1 = Colonne(2, i) Exit For End If Next i For i = 1 To 26 If Colonne(1, i) = Right(col, 1) Then indice2 = Colonne(2, i) Exit For End If Next i indice = (indice1 * 26) + indice2 End Select Colnuméric = indice End Function
'
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 ----------------------------------------------------------------------------------------------------------------------------CREATION LISTE PAR METHODE DICTIONNAIRE---------------------------------------------------------------------------------------------------------------------------- Sub Creer_Liste_Feuilles(Plage As Range) 'PRECAUTION PREALABLE : ACTIVER LA REFERENCE "MICROSOFT SCRIPTING RUNTIME" Dim Dico Dim c As Range Dim temp Dim d Dim d1 Dim d2 As String Set Dico = CreateObject("Scripting.Dictionary") For Each c In Plage If Not Dico.Exists(c.Value) Then Dico.Add c.Value, c.Value Next c temp = Dico.items Call Tri(temp, LBound(temp), UBound(temp)) ' voir module mod_tri For d = LBound(temp) To UBound(temp) 'l'argument de la procédure Gestion_Feuilles est de type string d1 = temp(d) d2 = IIf(IsNumeric(d1), CStr(d1), d1) Call Gestion_Feuilles(d2) Next d Set Dico = Nothing End Sub '---------------------------------------------------------------------------------------------------------------------------- TRI DE DICTIONNAIRE---------------------------------------------------------------------------------------------------------------------------- Sub Tri(a As Variant, gauc As Long, droi As Long) ' Quick sort Dim g As Long, d As Long Dim ref As Variant Dim t As Variant ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref g = g + 1 Loop Do While ref < a(d) d = d - 1 Loop If g <= d Then t = a(g) a(g) = a(d) a(d) = t g = g + 1 d = d - 1 End If Loop While g <= d If g < droi Then Call Tri(a, g, droi) If gauc < d Then Call Tri(a, gauc, d) End Sub
Partager