Discussion :

[lisandjo]

Bonjour à tous,

je sais qu'il y a déjà des forum pour ce genre de question mais je n'arrive vraiment pas avoir ce que je veux.

Différents personnels saisissent des données sur des classeurs différentes (chaque classeur contient uniquement 1 feuille et sont regroupé dans un même dossier). je dois faire une feuille excel qui reprendrait la totalité des données des feuilles des personnels pour en faire une synthèse.

Attention, chaque classeurs ont un nom différent et un nombre de lignes différents aussi. Par contre j'ai le même nombre de colonne pour chaque classeurs.

En résumé je souhaiterai un classeur "Global" avec une feuille qui reprendrait toutes les informations des autres classeurs nommé "UG ---" avec une macro.

Tout ce que j'ai pu lire jusqu'à présent n'était pas intéressant, soit parce que ca me regrouper tous les classeurs dans un seul soit parce qu'il y avait un bogg a chaque fois vu le nombre de classeurs que j'ai (environ 200 voir plus et le nombre ne va qu'en augmentant).

Merci d'avance

Lisandjo

[Jean-Philippe André]

salut,

le regroupement de n classeurs à 1 classeur ou de n classeurs à 1 feuille reste globalement le meme procédé

Si tu nous montres le code dont tu parles pour la gestion de n classeur vers 1 classeur, on pourra partir de là pour te proposer des solutions

[kiki29]

Salut, sans doute améliorable,allégeable car sorti des décombres de mon PC, à adapter pour la plage de données à copier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Wkb.Sheets(sNomFeuilleALire).Range("A1:Y" & LastRow).Copy

ainsi que pour le nom de la feuille dont sont extraites les données

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Const sNomFeuilleALire As String = "Material"

Affecter sur une feuille dont le CodeName est ShParam un bouton à la procédure SelDossier

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
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
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
 
Option Explicit
 
Dim TabFichiers() As String
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim n As Long, bFlagNomFeuille As Boolean
Dim iRow As Long, Cpt As Long, NbFichiers As Long, sNum As String, sNomAct As String
 
'   A Adapter
Const sNomFeuilleALire As String = "Material"
 
Const iRowDep As Long = 1
Const sNomFeuillesDatas As String = "Datas_"
Const TypeFichier As String = "xls"
 
Private Sub DelFeuilles()
Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If (Ws.Name <> ShParam.Name) And (Ws.Name Like sNomFeuillesDatas & "*") Then
            Application.DisplayAlerts = False
            Ws.Delete
            Application.DisplayAlerts = True
        End If
    Next Ws
End Sub
 
Private Function ExistenceNomFeuille(sNomFichier As String, sNomFeuille As String) As Boolean
Dim Conn As Object
Dim Cat As Object
Dim Feuille As Object
Dim sNom As String
 
    Set Conn = CreateObject("ADODB.Connection")
    Set Cat = CreateObject("ADOX.Catalog")
 
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & sNomFichier & ";" & _
              "Extended Properties=""Excel 8.0;"""
 
    Set Cat.ActiveConnection = Conn
 
    ExistenceNomFeuille = False
    For Each Feuille In Cat.Tables
        Select Case Right$(Feuille.Name, 1)
            Case "$"
                sNom = Left$(Feuille.Name, Len(Feuille.Name) - 1)
                If sNom = sNomFeuille Then
                    ExistenceNomFeuille = True
                    Exit For
                End If
            Case "'"
                sNom = Mid$(Feuille.Name, 2, Len(Feuille.Name) - 3)
                If sNom = sNomFeuille Then
                    ExistenceNomFeuille = True
                    Exit For
                End If
        End Select
    Next Feuille
 
    Conn.Close
    Set Cat = Nothing
    Set Conn = Nothing
End Function
 
Private Sub Init()
    iRow = iRowDep: Cpt = 0: NbFichiers = 0: n = 0: sNum = ""
    DelFeuilles
End Sub
 
Private Sub LectureFichiers()
Dim i As Long
    For i = 1 To UBound(TabFichiers)
        Lire TabFichiers(i)
        Cpt = Cpt + 1
    Next i
End Sub
 
Private Sub Lire(ByVal sNomFichier As String)
Dim FSO As Object
Dim Fichier As String
Dim LastRow As Long
Dim Wkb As Workbook, sNomSh As String
Dim LastRowPaste As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Fichier = FSO.GetFileName(sNomFichier)
 
    Application.DisplayAlerts = False
    Set Wkb = Application.Workbooks.Open(sNomFichier, UpdateLinks:=xlUpdateLinksNever, ReadOnly:=True)
    Application.DisplayAlerts = True
 
    LastRow = Wkb.Sheets(sNomFeuilleALire).Range("A" & Rows.Count).End(xlUp).Row
    LastRowPaste = iRow + LastRow - iRowDep
 
    If LastRowPaste > ShParam.Rows.Count Or sNum = "" Then
        iRow = iRowDep
        sNomSh = ThisWorkbook.ActiveSheet.Name
        ThisWorkbook.Sheets.Add
 
        n = n + 1
        Select Case n
            Case 1 To 9: sNum = "00" & CStr(n)
            Case 10 To 99: sNum = "0" & CStr(n)
            Case Else: sNum = CStr(n)
        End Select
 
        With ThisWorkbook
            .ActiveSheet.Name = sNomFeuillesDatas & sNum
            .ActiveSheet.Move After:=.Worksheets(sNomSh)
            .ActiveSheet.Range("A" & iRow).Select
            ActiveWindow.FreezePanes = True
        End With
        sNomAct = sNomFeuillesDatas & sNum
    End If
 
    ' Plage à Copier et donc à adapter
    Wkb.Sheets(sNomFeuilleALire).Range("A1:Y" & LastRow).Copy
    ThisWorkbook.Worksheets(sNomAct).Range("A" & iRow).PasteSpecial xlPasteValues
 
    iRow = iRow + LastRow
 
    With Application
        .StatusBar = "Lecture Fichiers : " & Cpt + 1 & " / " & NbFichiers
        .CutCopyMode = False
    End With
 
    Wkb.Close False
    Set FSO = Nothing
End Sub
 
Private Sub ListeFichiersDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    Fichier = Dir$(sChemin & "\*.*")
    Do While Len(Fichier) > 0
        sPath = sChemin & "\" & Fichier
        If Fichier <> ThisWorkbook.Name And UCase(TypeFichier) = UCase(FSO.GetExtensionName(Fichier)) Then
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabFichiers(1 To NbFichiers)
            TabFichiers(NbFichiers) = sPath
        End If
        Fichier = Dir$()
    Loop
 
    If bInclureSousDossiers Then
        For Each Dossier In Dossier.SubFolders
            ListeFichiersDossier Dossier.Path, True
        Next Dossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub MepFeuilles()
Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If (Ws.Name <> ShParam.Name) And (Ws.Name Like sNomFeuillesDatas & "*") Then
            With Ws
                .Activate
                .Tab.ColorIndex = 19
                .Columns("A:Y").Columns.AutoFit
                .Range("A1").Select
            End With
        End If
    Next Ws
End Sub
 
Private Sub MepFinale()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    With ShParam
        .Activate
        .Range("C1").Select
    End With
End Sub
 
Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
 
            QueryPerformanceCounter Dep
 
            Init
 
            DoEvents
            Application.ScreenUpdating = False
 
            ListeFichiersDossier .SelectedItems(1), False
 
            If NbFichiers = 0 Then
                MepFinale
                Application.ScreenUpdating = True
                MsgBox "Pas de fichier xls dans " & .SelectedItems(1), vbOKOnly + vbInformation, "Infos"
                Exit Sub
            End If
 
            TestExistenceFeuilleDossier
 
            If bFlagNomFeuille = False Then
                MepFinale
                Application.ScreenUpdating = True
                Exit Sub
            End If
 
            LectureFichiers
            MepFeuilles
            MepFinale
 
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
 
            With Application
                .ScreenUpdating = True
                .StatusBar = "Terminé : Fichiers  " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
            End With
        End If
 
        With ShParam
            .Activate
            .Range("C1").Select
        End With
    End With
End Sub
 
Private Sub TestExistenceFeuilleDossier()
Dim i As Long, sNomFichier As String
Dim iMax As Long
 
    iMax = UBound(TabFichiers)
    bFlagNomFeuille = True
 
    For i = LBound(TabFichiers) To UBound(TabFichiers)
        bFlagNomFeuille = ExistenceNomFeuille(TabFichiers(i), sNomFeuilleALire)
        If bFlagNomFeuille = False Then
            Application.ScreenUpdating = True
            sNomFichier = TabFichiers(i)
            MsgBox "La feuille " & sNomFeuilleALire & " n'existe pas dans " & vbCrLf & sNomFichier, vbOKOnly + vbInformation
            Exit Sub
        End If
        Application.StatusBar = "Vérification existence : " & sNomFeuilleALire & "  " & i & " / " & iMax
    Next i
End Sub

[lisandjo]

Bonjour,

Merci pour vos réponse rapide.

kiki29 : je ne suis pas du tout experte en macro, j'ai des notions quand j'utilise l'enregistreur mais pas dans la lecture ou la transformation d'un macro. Quand je copie ta macro, elle ne fonctionne pas

jpcheck : voici le type de macro qui m'intéresserai mais a chaque fois il me dit qu'il ne trouve pas le fichier Material or je l'ai créée.

Voici la macro!

Comme je vous l'ai dis, il y a plusieurs classeurs à copier en même temps intitulé "UG 123" ou "UG 124" .... et je voudrais les rassembler sur une feuille d'un autre classeur (peu m'importe le nom)

Merci d'avance de votre compréhension.

[lisandjo]

kiki29 : j'ai repris ta macro et essayer de la faire marcher. J'ai changer le nom de la feuille à lire mais elle bloque sur ShParam et franchement je ne sais pas trop à quoi ca correspond.

Par ailleurs, je crois que ta macro prend les données dans un classeur et les transferts dans d'autres or moi c'est l'inverse, je dois prendre dans plusieurs classeurs pour le mettre dans un seule feuille.

[kiki29]

Salut, il s'agit du CodeName voir ici

Copie le code donné plus haut dans un nouveau classeur et remplace dans le code ShParam par Feuil1 qui est le CodeName par défaut

Le code fourni te demande de sélectionner le dossier à traiter, il etablit une liste interne dans un tableau des classeurs contenus dans ce dossier en vérifiant que chaque classeur a une feuille nommée "Matérial" puis dans une feuille "Data_xxx", qu'il crée à la volée, copie les données de chaque feuille "Matérial" de chacun de ces classeurs à la queue leu leu pour la plage

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Wkb.Sheets(sNomFeuilleALire).Range("A1:Y" & LastRow).Copy

Si la quantité de données dépasse les 65536 lignes ou plus suivant la version d'Excel, il crée une autre feuille Data_xxx, x peut varier de 1 à 999, ce qui laisse de la marge

Le code fourni est issu de l'adaptation de fichier FICHIER UNIQUE RECAP .xls , que j'avais fourni il y a longtemps sur ce forum, il me semble.

[lisandjo]

KIKI : MERCI MERCI MERCI ET MILLE FOIS MERCI

ça marche nickel comme il faut et en plus tu m'as répondu très vite et franchement c'est génial tu ne sais même pas à quel point cela va m'aider et surtout ça sera bcp plus rapide de travaillé.

MERCI ENCORE

Et en plus j'ai encore appris pleins de choses sur les macros

[kiki29]

Salut, un enthousiasme qui fait plaisir, as-tu vérifié pour la plage à copier, par défaut elle allait jusqu'à la colonne Y ?

PS: Une remarque dans la procédure SelDossier, il y a :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ListeFichiersDossier .SelectedItems(1), False

Cela permet une recherche récursive ou non dans les sous dossiers via True/False
par défaut ici à False et donc se limitant au dossier racine sélectionné

[lisandjo]

Bonjour

kiki29 : J'ai vérifier pour le nombre de colonne. Par ailleurs, pour SelDossier, je n'avais pas vraiment bien regarder et après vérification, ça me convient parfaitement.

D'ailleurs, par la suite, j'ai améliorer la macro avec d'autres comme la mise en forme, les sous totaux etc.. et franchement c'est super. Le mois dernier j'ai mis 2 jours à faire tout ce travail et en plus il y avait des erreurs et maintenant en 2 min j'ai tout et sans aucune erreur.

D'où mon enthousiasme et mes remerciements. LE ga

fausse manip.

Aller merci encore

à bientôt

BYEBYE

ccool: