VBA Synthèse de plusieurs classeurs

[C@thy]

Bonjour,

je dispose de 1500 à 5000 classeurs que je dois agréger.

Chaque classeur comporte une seule ligne remplie : la ligne 9

je dois agréger tous mes classeurs dans un classeur unique, les lignes les unes en-dessous des autres (pour ensuite faire un TCD).

j'ai commencé le boulot (fichier Synthèse), mais là je bloque et j'ai besoin de votre aide.

En plus, j'ai simplifié la macro, mes les classeurs à agréger se situent dans tous les sous-répertoires du classeur actif (j'ai fait comme si ils étaient dans le même répertoire).

Un grand MERCI si vous pouvez m'aider.

Bises et bonne soirée

C@thy

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

voici l'objet du délit...

Bises

C@thy

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Arf! c'est pas le bon fichier

voilà...

C@thy

 

[pierrejean]

Re : VBA Synthèse de plusieurs classeurs

Re

teste

       Range("A9:L" & Workbooks(nf).Sheets(1).[A65000].End(xlUp).Row).Copy Workbooks(ClasseurMaitre).Sheets(1).Range("B" & Ligne)

au lieu de

[A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).Range("B" & Ligne)

 

[BOISGONTIER]

Re : VBA Synthèse de plusieurs classeurs

Bonjour,

Sub ConsolideSousRepRepActuel()
  Application.ScreenUpdating = False
  [A9:M1000].ClearContents
  répertoire = ThisWorkbook.Path
  ClasseurMaitre = ThisWorkbook.Name
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier = fs.getfolder(répertoire)
  For Each d In dossier.SubFolders
    sousRépertoire = d.Name
    nf = Dir(répertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
    Do While nf <> ""
       Workbooks.Open Filename:=répertoire & "\" & sousRépertoire & "\" & nf
       [A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Offset(1, 0)
       nlig = [A20].End(xlUp).Row - 8
       Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 0).Resize(nlig).Value = [C5]
       ActiveWorkbook.Close False
       nf = Dir ' fichier suivant
    Loop
   Next
End Sub

JB

 

[kiki29]

Re : VBA Synthèse de plusieurs classeurs

Salut, à tester

 

[kiki29]

Re : VBA Synthèse de plusieurs classeurs

Re, une version ADO également à tester

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Un énorme MERCI à vous tous, c'est super sympa de m'apporter votre aide.

J'ai un petit souci : tout ne fonctionne pas comme je veux.

Boisgontier, lorsque j'ai des classeurs remplis jusqu'en ligne 19 ça fonctionne à merveille, mais dès que j'en ai plus ça ne va plus nlig est égal à 0, or, j'ai mis 20 à titre d'exemple mais ça peut aller jusqu'à 400 ou 500 je n'ai pas encore les vrais fichiers remplis.

Comme tu l'as bien compris, le souci ce sont ces 3 lignes en fin de données.
Ils font tout pour m'empoisonner la vie, ces utilisateurs!

Je réfléchis encore à la question, mais on avance dans le bon sens.

Je n'ai pas réussi à remplir mon tableau avec la macro de Kiki29 (du Finistère??? Kenavo!).

J'avance encore un peu et je vous tiens au courant.

Bises et bonne journée ensoleillée à tous

C@thy

 

[BOISGONTIER]

Re : VBA Synthèse de plusieurs classeurs

Bonjour,

Sub ConsolideSousRepRepActuel()
  Application.ScreenUpdating = False
  [A9:M1000].ClearContents
  répertoire = ThisWorkbook.Path
  ClasseurMaitre = ThisWorkbook.Name
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier = fs.getfolder(répertoire)
  For Each d In dossier.SubFolders
    sousRépertoire = d.Name
    nf = Dir(répertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
    Do While nf <> ""
       Workbooks.Open Filename:=répertoire & "\" & sousRépertoire & "\" & nf
       '---
       If [A9] <> "" Then
         nlig = [A8].End(xlDown).Row - 8
         [A9].Resize(nlig, 12).Copy Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Offset(1, 0)
         Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 0).Resize(nlig).Value = [C5]
       End If
       ActiveWorkbook.Close False
       nf = Dir ' fichier suivant
    Loop
   Next
End Sub

JB

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

MERCIiiiiiiiiiiiiiiiiiiiiiii Boisgontier, c'est parfait

de mon côté j'étais en train de "bidouiller" un truc,
mais... laborieux, tu vas voir...

Sub ConsolideSousRepRepActuel()
   Application.ScreenUpdating = False
   [A9:L1500].ClearContents
   [A9:L1500].Interior.ColorIndex = xlNone
   repertoire = ThisWorkbook.Path
   ClasseurMaitre = ThisWorkbook.Name
   Racine = ThisWorkbook.Path                  ' Répertoire courant
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set dossier = fs.getfolder(Racine)  'S'il n'y a qu'un niveau de sous-répertoires.
   For Each d In dossier.SubFolders
     sousRépertoire = d.Name
     nf = Dir(repertoire & "\" & sousRépertoire & "\*.xls")    ' premier fichier
     Do While nf <> ""
       Workbooks.Open Filename:=repertoire & "\" & sousRépertoire & "\" & nf
       Ligne = Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Row + 1
       FinLigne = Workbooks(nf).Sheets(1).[B65000].End(xlUp).Row
       nbLigne = FinLigne - 8
Range("A9:L" & FinLigne).Copy Workbooks(ClasseurMaitre).Sheets(1).Range("B" & Ligne)
  [C5].Copy Workbooks(ClasseurMaitre).Sheets(1).Range("A" & Ligne)
ActiveWorkbook.Close False
Ligne2 = Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Row
If Ligne <> Ligne2 Then
Range("A" & Ligne).Select
Selection.AutoFill Destination:=Range("A" & Ligne & ":A" & Ligne2)
End If
      nf = Dir ' fichier suivant
    Loop
   Next
End Sub

Donc ton code est nettement plus mieux bien.

Un grand grand merci à tous les protagonistes de ce fil, vous êtes SUPER!!!

Gros bisous et bonne journée

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Ah ben oui!!! j'avais oublié le xlDown, dans ce cas c'est nettement mieux que d'utiliser xlUp!!!
Bravo! Je n'y avais pas pensé!!!

Biz

C@thy