[XL-2010] Créer des classeurs excel a partir d'un tableau vba

Créer des classeurs excel a partir d'un tableau vba

Bonjour,

J'ai un fichier excel avec 3 onglets.

_ Le premier contient des données a rapatrier dans les 2 autres onglets, "Nom_DR" et "CODE_RR" (Comme une recherchev).
_ Le deuxième contient les données des CONVIVES
_ Le troisième contient les données du PERSONNEL

Ma macro doit faire :

_ Rapatrier les données du premier onglet dans les 2 autres. Ca c'est bon.
_ Pour les CONVIVES comme pour le PERSONNEL je dois créer un classeur par "Nom_DR" contenu dans l'onglet. Et chaque Classeur dois avoir autant d'onglet que de Code RR nommé comme le code. C'est la que je coince.

J'ai créé pour les CONVIVES et pour le PERSONNEL 2 tableaux.
_ 1 avec une liste distinct des Nom_DR (1 tab pour CONVIVES et 1 Tab pour PERSONNEL)
_ 1 multidimensionnel avec le Nom_DR et le Code_RR associé. (Pas de doublon bien sur) (1 tab pour CONVIVES et 1 Tab pour PERSONNEL)

Je voulais parcourir mon premier tableau pour créé mes classeurs et parcourir mon deuxième tableau pour créer les onglets.

J'y arrive mais que pour des classeur xls. Je n'arrive pas à créé des classeur xlsx.
Lorsque ma macro est fini mes onglets sont vide.
J'essaye de les remplir mais c'est la que je bloc.

Voici mon code en entier (Attention je suis en train de changer la fin donc ce n'est pas au point) :

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
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
Sub Verbatim_Sodexo()
 
'Déclaration des variables
 
Dim nbliDF As Integer 'Nb de ligne non vide de l'onglet Données Fichier
Dim nbliCONV As Integer 'Nb de ligne non vide de l'onglet Base Convives
Dim nbliPERS As Integer 'Nb de ligne non vide de l'onglet Base Personnel
 
Dim nbcolDF As Integer 'Nb de colonne non vide de l'onglet Données Fichier
Dim nbcolCONV As Integer 'Nb de colonne non vide de l'onglet Base Convives
Dim nbcolPERS As Integer 'Nb de colonne non vide de l'onglet Base Personnel
Dim colFR As Integer 'Num de la colonne du code FR
 
Dim nbWS As Integer
 
Dim iDF As Integer
Dim jDF As Integer
 
Dim iCONV As Integer
Dim jCONV As Integer
 
Dim iPERS As Integer
Dim jPERS As Integer
 
Dim Q As Integer
Dim l As Integer
Dim cpt As Integer
 
Dim JRR As Integer 'Num colonne "CODERR"
Dim JDR As Integer 'Num colonne "NOM_DR"
 
Dim t As Integer 'Pour boucler les lignes des tableaux
 
Dim TabCONV_DR() As String
Dim TabCONV_RR() As String
 
Dim TabPERS_DR() As String
Dim TabPERS_RR() As String
 
Dim Nom_Classeur As String
Dim Chemin As String
Chemin = Workbooks(ActiveWorkbook.Name).Path
 
'Programme
 
nbliDF = ActiveWorkbook.Worksheets("Données Fichier").Cells(Rows.Count, 1).End(xlUp).Row 'num de la dernière ligne non vide des données de fichier
nbcolDF = ActiveWorkbook.Worksheets("Données Fichier").Cells(1, Columns.Count).End(xlToLeft).Column 'num de la dernière colonne non vide des données de fichier
 
'Importation des données de fichier dans les bases Convives et Personnel
 
Worksheets("Données Fichier").Activate
 
'Importation des intitulés de colonne des données de fichier
Q = 4
For jDF = 1 To nbcolDF
    If Cells(1, jDF) <> "FR" Then
    ActiveWorkbook.Worksheets("Base Convives").Cells(1, Q) = Cells(1, jDF)
    ActiveWorkbook.Worksheets("Base Personnel").Cells(1, Q) = Cells(1, jDF)
    Q = Q + 1
    Else
    colFR = jDF
    End If
Next jDF
 
nbliCONV = ActiveWorkbook.Worksheets("Base Convives").Cells(Rows.Count, 1).End(xlUp).Row 'num de la dernière ligne non vide de la base Convives
nbliPERS = ActiveWorkbook.Worksheets("Base Personnel").Cells(Rows.Count, 1).End(xlUp).Row 'num de la dernière ligne non vide de la base Personnel
nbcolCONV = ActiveWorkbook.Worksheets("Base Convives").Cells(1, Columns.Count).End(xlToLeft).Column 'num de la dernière colonne non vide de la base Convives
nbcolPERS = ActiveWorkbook.Worksheets("Base Personnel").Cells(1, Columns.Count).End(xlToLeft).Column 'num de la dernière colonne non vide de la base Personnel
 
'Importation des données
For iDF = 2 To nbliDF
 
    'Partie Base Convives
    For iCONV = 2 To nbliCONV
        If Not IsEmpty(ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, 2)) Then
            If ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, 2) = Cells(iDF, colFR) Then
                For jDF = 1 To nbcolDF
                    For jCONV = 4 To nbcolCONV
                        If ActiveWorkbook.Worksheets("Base Convives").Cells(1, jCONV) = Cells(1, jDF) Then
                        ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, jCONV) = Cells(iDF, jDF)
                        End If
                    Next jCONV
                Next jDF
            End If
        End If
    Next iCONV
 
    'Partie Base Personnel
    For iPERS = 2 To nbliPERS
        If Not IsEmpty(ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, 2)) Then
            If ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, 2) = Cells(iDF, colFR) Then
                For jDF = 1 To nbcolDF
                    For jPERS = 4 To nbcolPERS
                        If ActiveWorkbook.Worksheets("Base Personnel").Cells(1, jPERS) = Cells(1, jDF) Then
                        ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, jPERS) = Cells(iDF, jDF)
                        End If
                    Next jPERS
                Next jDF
            End If
        End If
    Next iPERS
Next iDF
 
' Tableau des Nom_DR CONVIVES
l = 0
ReDim Preserve TabCONV_DR(l)
 
For jCONV = 1 To nbcolCONV
    If ActiveWorkbook.Worksheets("Base Convives").Cells(1, jCONV) = "NOM_DR" Then
        JDR = jCONV
        TabCONV_DR(0) = ActiveWorkbook.Worksheets("Base Convives").Cells(2, jCONV)
    End If
Next jCONV
 
For iCONV = 3 To nbliCONV
rep = 0
    For t = 0 To UBound(TabCONV_DR)
        If ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, JDR) = TabCONV_DR(t) Then
        rep = 1
        End If
    Next t
 
    If rep = 0 Then
        l = l + 1
        ReDim Preserve TabCONV_DR(l)
        TabCONV_DR(l) = ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, JDR)
    End If
 
Next iCONV
 
' Tableau des Nom_DR PERSONNEL
l = 0
ReDim Preserve TabPERS_DR(l)
 
For jPERS = 1 To nbcolPERS
    If ActiveWorkbook.Worksheets("Base Personnel").Cells(1, jPERS) = "NOM_DR" Then
        JDR = jPERS
        TabPERS_DR(0) = ActiveWorkbook.Worksheets("Base Personnel").Cells(2, jPERS)
    End If
Next jPERS
 
For iPERS = 3 To nbliPERS
rep = 0
    For t = 0 To UBound(TabPERS_DR)
        If ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, JDR) = TabPERS_DR(t) Then
        rep = 1
        End If
    Next t
 
    If rep = 0 Then
        l = l + 1
        ReDim Preserve TabPERS_DR(l)
        TabPERS_DR(l) = ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, JDR)
    End If
 
Next iPERS
 
' Tableau des CODE_RR CONVIVES
l = 0
ReDim Preserve TabCONV_RR(1, l)
 
For jCONV = 4 To nbcolCONV
    If ActiveWorkbook.Worksheets("Base Convives").Cells(1, jCONV) = "CODERR" Then
        JRR = jCONV
        TabCONV_RR(0, 0) = ActiveWorkbook.Worksheets("Base Convives").Cells(2, JDR)
        TabCONV_RR(1, 0) = ActiveWorkbook.Worksheets("Base Convives").Cells(2, JRR)
    End If
Next jCONV
 
 
For iCONV = 3 To nbliCONV
rep = 0
    For t = 0 To UBound(TabCONV_RR, 2)
        If ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, JDR) = TabCONV_RR(0, t) Then
            If ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, JRR) = TabCONV_RR(1, t) Then
            rep = 1
            End If
        End If
    Next t
 
    If rep = 0 Then
        l = l + 1
        ReDim Preserve TabCONV_RR(1, l)
        TabCONV_RR(0, l) = ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, JDR)
        TabCONV_RR(1, l) = ActiveWorkbook.Worksheets("Base Convives").Cells(iCONV, JRR)
    End If
 
Next iCONV
 
' Tableau des CODE_RR PERSONNEL
l = 0
ReDim Preserve TabPERS_RR(1, l)
 
For jPERS = 4 To nbcolPERS
    If ActiveWorkbook.Worksheets("Base Personnel").Cells(1, jPERS) = "CODERR" Then
        JRR = jPERS
        TabPERS_RR(0, 0) = ActiveWorkbook.Worksheets("Base Personnel").Cells(2, JDR)
        TabPERS_RR(1, 0) = ActiveWorkbook.Worksheets("Base Personnel").Cells(2, JRR)
    End If
Next jPERS
 
 
For iPERS = 3 To nbliPERS
rep = 0
    For t = 0 To UBound(TabPERS_RR, 2)
        If ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, JDR) = TabPERS_RR(0, t) Then
            If ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, JRR) = TabPERS_RR(1, t) Then
            rep = 1
            End If
        End If
    Next t
 
    If rep = 0 Then
        l = l + 1
        ReDim Preserve TabPERS_RR(1, l)
        TabPERS_RR(0, l) = ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, JDR)
        TabPERS_RR(1, l) = ActiveWorkbook.Worksheets("Base Personnel").Cells(iPERS, JRR)
    End If
 
Next iPERS
 
'création des classeurs CONVIVES
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
 
For i = 0 To UBound(TabCONV_DR)
cpt = 0
k = 0
    'On créer l'objet Excel
    Set xlApp = CreateObject("Excel.Application")
 
    'On défini le nombre d'onglets
    For J = 0 To UBound(TabCONV_RR, 2)
        If TabCONV_RR(0, J) = TabCONV_DR(i) Then
        cpt = cpt + 1
        End If
    Next J
 
    xlApp.SheetsInNewWorkbook = cpt
 
    'On ajoute un classeur
    Set xlBook = xlApp.Workbooks.Add
 
    'On donne un nom au classeur
    xlBook.SaveAs (Chemin & "\CONVIVES_" & TabCONV_DR(i) & ".xls")
 
    'On rend le classeur visible
    xlApp.Visible = True
 
    'On créer l'objet onglet dans le nouveau classeur créé
    For J = 0 To UBound(TabCONV_RR, 2)
 
        If TabCONV_RR(0, J) = TabCONV_DR(i) Then
        k = k + 1
        Set xlSheet = xlBook.Worksheets(k)
 
        'On affecte un nom aux l'onglets
        xlSheet.Name = TabCONV_RR(1, J)
 
        'On copie les données
        Worksheets("Base Convives").Activate
        Range(Cells(1, 1), Cells(nbliCONV, nbcolCONV)).Select
        Selection.Copy
        Nom_Classeur = "CONVIVES_" & TabCONV_DR(i) & ".xls"
 
        'Workbooks(Nom_Classeur).Activate
        'Worksheets(TabCONV_RR(1, J)).Activate
        Worksheets(TabCONV_RR(1, J)).Cells(1, 1).Select
        ActiveSheet.Paste
 
        End If
 
    'on libère l'objet onglet pour pouvoir en créer un nouveau ... etc
    Set xlSheet = Nothing
    Next J
 
    'On remet la propriété de l'application à 3 (par défaut)
    xlApp.SheetsInNewWorkbook = 3
    'On ferme l'application
    xlApp.Quit
Next i
 
MsgBox ("Terminé")
End Sub

La je bloc c'est sur cette partie :

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
'création des classeurs CONVIVES
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
 
For i = 0 To UBound(TabCONV_DR)
cpt = 0
k = 0
    'On créer l'objet Excel
    Set xlApp = CreateObject("Excel.Application")
 
    'On défini le nombre d'onglets
    For J = 0 To UBound(TabCONV_RR, 2)
        If TabCONV_RR(0, J) = TabCONV_DR(i) Then
        cpt = cpt + 1
        End If
    Next J
 
    xlApp.SheetsInNewWorkbook = cpt
 
    'On ajoute un classeur
    Set xlBook = xlApp.Workbooks.Add
 
    'On donne un nom au classeur
    xlBook.SaveAs (Chemin & "\CONVIVES_" & TabCONV_DR(i) & ".xls")
 
    'On rend le classeur visible
    xlApp.Visible = True
 
    'On créer l'objet onglet dans le nouveau classeur créé
    For J = 0 To UBound(TabCONV_RR, 2)
 
        If TabCONV_RR(0, J) = TabCONV_DR(i) Then
        k = k + 1
        Set xlSheet = xlBook.Worksheets(k)
 
        'On affecte un nom aux l'onglets
        xlSheet.Name = TabCONV_RR(1, J)
 
        'On copie les données
        Worksheets("Base Convives").Activate
        Range(Cells(1, 1), Cells(nbliCONV, nbcolCONV)).Select
        Selection.Copy
        Nom_Classeur = "CONVIVES_" & TabCONV_DR(i) & ".xls"
 
        'Workbooks(Nom_Classeur).Activate
        'Worksheets(TabCONV_RR(1, J)).Activate
        Worksheets(TabCONV_RR(1, J)).Cells(1, 1).Select
        ActiveSheet.Paste
 
        End If
 
    'on libère l'objet onglet pour pouvoir en créer un nouveau ... etc
    Set xlSheet = Nothing
    Next J
 
    'On remet la propriété de l'application à 3 (par défaut)
    xlApp.SheetsInNewWorkbook = 3
    'On ferme l'application
    xlApp.Quit
Next i

J'arrive à créé mes classeurs en xls ainsi que leurs onglets mais je n'arrive pas à copier les données de mon premier classeur (en xlsx lui) sur mes autres classeurs en xls.

Code:

1
2
3
4
5
6
7
8
9
10
        'On copie les données
        Worksheets("Base Convives").Activate
        Range(Cells(1, 1), Cells(nbliCONV, nbcolCONV)).Select
        Selection.Copy
        Nom_Classeur = "CONVIVES_" & TabCONV_DR(i) & ".xls"
 
        Workbooks(Nom_Classeur).Activate
        Worksheets(TabCONV_RR(1, J)).Activate
        Cells(1, 1).Select
        ActiveSheet.Paste

l'activation du Workbooks(Nom_Classeur) ne fonctionne pas.

Merci de votre aide

Bonjour,

Tu n'as pas besoin de ceci

Citation:

'création des classeurs CONVIVES
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Un simple Workbooks.Add va te créer un nouveau classeur (dans la même session) prêt à y intégrer des feuilles et y copier tes données.

Merci Parmi.

Je suis partie comme tu me l'a conseillé et ca marche.
Voici mon 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
    'Création des onglets
    For J = 0 To UBound(TabCONV_RR, 2)
 
        If TabCONV_RR(0, J) = TabCONV_DR(i) Then
        Sheets.Add.Name = TabCONV_RR(1, J)
        cpt = cpt + 1
        End If
 
    Next J
 
    'Suppression des feuil1,2 et 3
    For J = cpt + 3 To cpt + 1 Step -1
    Sheets(J).Delete
    Next J
 
    'Sauvegarde du classeur en le renomant
    ActiveWorkbook.SaveAs (Chemin & "\CONVIVES_" & TabCONV_DR(i) & ".xlsx")
 
    For J = 0 To UBound(TabCONV_RR, 2)
    l = 2
        If TabCONV_RR(0, J) = TabCONV_DR(i) Then
 
            'Copie la ligne de titre
 
            Workbooks("Mask_Macro_Verbatim_Sodexo.xlsx").Activate
            ActiveWorkbook.Worksheets("Base Convives").Rows("1:1").Select
            Selection.Copy
 
            Workbooks("CONVIVES_" & TabCONV_DR(i) & ".xlsx").Activate
            ActiveWorkbook.Worksheets(TabCONV_RR(1, J)).Rows("1:1").Select
            Selection.Paste
 
            For jCONV = 3 To nbcolCONV 'Parcour les colonnes de la base CONVIVES
                For iCONV = 2 To nbliCONV 'Parcour les lignes de la base CONVIVES
                    If Not IsEmpty(Workbooks("Mask_Macro_Verbatim_Sodexo").Worksheets("Base CONVIVES").Cells(iCONV, 3)) Then 'Si question ouverte n'est pas vide
                        If Workbooks("Mask_Macro_Verbatim_Sodexo").Worksheets("Base CONVIVES").Cells(1, jCONV) = "NOM_DR" Then 'Cherche la colonne Nom_DR
                            If Workbooks("Mask_Macro_Verbatim_Sodexo").Worksheets("Base CONVIVES").Cells(iCONV, jCONV) = TabCONV_DR(i) Then 'Si le nom DR correspond au classeur
                                If Workbooks("Mask_Macro_Verbatim_Sodexo").Worksheets("Base CONVIVES").Cells(1, jCONV) = "CODERR" Then 'Cherche la colonne CODERR
                                    If Workbooks("Mask_Macro_Verbatim_Sodexo").Worksheets("Base CONVIVES").Cells(iCONV, jCONV) = TabCONV_RR(1, J) Then 'Si le CODERR correspond à l'onglet
                                        Workbooks("Mask_Macro_Verbatim_Sodexo").Worksheets("Base CONVIVES").Rows(iCONV).Select
                                        Selection.Copy
                                        Workbooks("CONVIVES_" & TabCONV_DR(i)).Worksheets(TabCONV_RR(1, J)).Rows(l).Select
                                        Selection.Paste
                                        l = l + 1
                                    End If
                                End If
                            End If
                        End If
                    End If
                Next iCONV
            Next jCONV
        End If
    Next J
Next i

Ce qui est dommage avec ce code c'est que je ne sais comment créer un classeur avec directement le bon nombre de feuille sans avoir à les rajouter avec .add

Code:

1
2
3
4
5
6
7
    Dim nbFeuilles As Integer
 
    nbFeuilles = Application.SheetsInNewWorkbook  'garde en mémoire le nombre de feuilles par défaut
 
    Application.SheetsInNewWorkbook = 15  'Crée les nouveaux fichiers avec 15 feuilles
    Workbooks.Add
    Application.SheetsInNewWorkbook = nbFeuilles  'remet le nombre par défaut