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

 

[BOISGONTIER]

Re : VBA Synthèse de plusieurs classeurs

Bonjour,

Sub syntèseClasseursBD2()
  Application.ScreenUpdating = False
  sousRépertoire = "BD"
  [A9:L1000].ClearContents
  actuel = ThisWorkbook.Name
  Repertoire = ThisWorkbook.Path
  nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls")    ' premier fichier
  Do While nf <> ""
     Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
     [A9:L20].Copy Workbooks(actuel).Sheets(1).[A65000].End(xlUp).Offset(1, 0)
     ActiveWorkbook.Close False
     nf = Dir ' fichier suivant
  Loop
End Sub

JB

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Un grand merci pour ta réponse si rapide et efficace!!! (ça fonctionne nickel!)

En fait, mes fichiers sont dans plusieurs sous-répertoires selon les grandes enseignes des magasins, donc il faut que je balaye tous les sous-répertoires.

Merci à toi.

Biz

C@thy

 

[BOISGONTIER]

Re : VBA Synthèse de plusieurs classeurs

Consolide toute l'arborescence des sous-répertoires:

Dim ClasseurMaitre
Sub ConsolideArborescence()
  Application.ScreenUpdating = False
  [A9:L1000].ClearContents
  ClasseurMaitre = ThisWorkbook.Name
  repertoire = ThisWorkbook.Path
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set DossierRacine = fs.getfolder(repertoire)
  Lit_dossier DossierRacine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
   For Each f In dossier.Files
     nf = f.Name
     If nf <> ClasseurMaitre Then
       Workbooks.Open Filename:=dossier & "\" & nf
       [A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 0)
       ActiveWorkbook.Close False
     End If
   Next
End Sub

S'il n'y a qu'un niveau de sous-répertoires.

Sub ConsolideSousRepRepActuel()
   Application.ScreenUpdating = False
   [A9:L1000].ClearContents
   repertoire = ThisWorkbook.Path
   ClasseurMaitre = ThisWorkbook.Name
   Racine = ThisWorkbook.Path                  ' Répertoire courant
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set dossier = fs.getfolder(Racine)
   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
       [A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 0)
       ActiveWorkbook.Close False
       nf = Dir ' fichier suivant
    Loop
   Next
End Sub

JB

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Bravo à toi, c'est vraiment TOP!!!

Ca fonctionne super bien et c'est très rapide.

C'est fou ce qu'on peut faire avec Excel pour peu qu'on le maîtrise bien...

Un grand grand merci

Bises et bonne journée

C@thy

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Euh... juste encore un petit truc,

j'ai dû rajouter dans mon classeur destination une colonne avant la A pour y mettre le contenu de la cellule C5 (nom de la chaîne de supermarchés)
qui doit figurer sur chaque ligne recopiée

j'ai modifié comme suit :

[A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 1)

(ça, ça va)

[C5].Copy Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Offset(1, -1)

ça, ça va pô

quelqu'un peut me dire comment corriger???

Un grand merci.

C@thy

 

[pierrejean]

Re : VBA Synthèse de plusieurs classeurs

Bonjour C@thy
Salut JB

ce que j'ecrirais:

Ligne=Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Row
[A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).Range("B" & Ligne)
[C5].Copy Workbooks(ClasseurMaitre).Sheets(1).range("A" & Ligne)

Bises

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Salut PJ, c'est toujours un plaisir de te retrouver.

J'ai testé ton code. Ca ne marche pas comme je voudrais :
il m'efface mes titres en ligne 8 et ne copie rien dans la colonne A... grrrr...

merci pour cet essai (non transformé!)

Bises

C@thy

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Autant pour moi, ton code est bon si on met Ligne + 1

certains de mes fichiers n'avaient rien en C5!!

Merci à toi, bisous et bon ouik

C@thy

 

[pierrejean]

Re : VBA Synthèse de plusieurs classeurs

Re

Un peu de precipitation en effet
teste avec

Ligne=Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Row[COLOR=blue]+1[/COLOR]

Et assure toi qu'il y a bien quelque chose a copier
Avec par exemple

msgbox([A9]
msgbox([C5])

Bisous et bon week end
Moi je pars voir ma très charmante Belle-Maman

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Merci à toi,

c'est mieux mais... des fois j'ai plusieurs lignes à recopier (j'ai mis jusqu'à 20 mais en réalité il peut y en avoir jusqu'à 400), et dans ce cas il ne recopie que la 1ère...
je pense qu'il faut aussi rajouter un comptage des lignes du tableau qu'on copie,
mais ça va un peu rallonger la sauce
ça marchait super bien avant que je rajoute ma colonne et il n'y avait pas de comptage de lignes du tableau à copier...

Bizettes

C@thy

 

[pierrejean]

Re : VBA Synthèse de plusieurs classeurs

Re

Tu nous en dira tant !!
En fait je n'avais pas remarqué que tu copiais plusieurs lignes

teste

Ligne=Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Row+1
[A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).Range("B" & Ligne)
for n=0 to 11 ' 11=(20-9 ) = nbre de lignes
  [C5].Copy Workbooks(ClasseurMaitre).Sheets(1).range("A" & Ligne)
  Ligne=Ligne+1
next n

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Comme j'ai parfois plusieurs lignes à copier (j'ai mis jusqu'à 20 mais ça peut aller jusqu'en ligne 400 en réalité), j'ai essayé ça :

[A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 1)
Ligne = Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Row + 1
[C5].Copy Workbooks(ClasseurMaitre).Sheets(1).Range("A" &Ligne)/CODE]
c'est pas top non plus, il me copie C5 en a mais après la dernière ligne alors que ça doit être [B]jusqu'à[/B] la dernière ligne.
 
si si on va y arriver...
 
Biz
 
[EMAIL="C@thy"]C@thy[/EMAIL]

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Ah oui, tu veux dire un truc comme ça :

Ligne = Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Row + 1
nbLigne = Workbooks(nf).Sheets(1).[A65000].End(xlUp).Row - 8
[A9:L20].Copy Workbooks(ClasseurMaitre).Sheets(1).Range("B" & Ligne)
For N = 1 To nbLigne
  [C5].Copy Workbooks(ClasseurMaitre).Sheets(1).Range("A" & Ligne)
  Ligne = Ligne + 1
Next N

Effectivement ça marche... (euh... y'a pas plus court???)

En tout cas merci à toi et bon ouik

Bisous

C@thy

 

[C@thy]

Re : VBA Synthèse de plusieurs classeurs

Non, ça marche pas super, j'ai des trous dans ma copien il saute des lignes

Bizzz

C@thy