synthèse de x fichiers excel

[bientot50]

Bonjour tout le monde et meilleurs voeux.

je fais une synthèse de 4 classeurs de 5 feuilles dans un classeur recap. Tous ces classeurs sont dans un même dossier dont le chemin est le suivant :
C:\Documents and Settings\xxxxxxxx\Bureau\VERO\Fusion\RECUPGLOBALE.

j'ai utilisé un code VBA de Jacques Boisgonthier que j'ai modifié comme ceci(salade maison )pour que toutes les feuilles de mes classeurs se copient l'une après l'autre dans les feuilles correspondantes de mon classeur récap :


Sub regrouper()
Dim ligne%
ChDir ActiveWorkbook.Path 'Chemin par défaut=emplacement du fichier "Récap"
Set recap = ThisWorkbook.Sheets("Chrono")
recap.Range("A3:F65500").Clear
compteur = 3 'puisque ligne 1 = en-têtes
nf = Dir("*.xls") 'tous les fichiers Excel (dans le chemin par défaut) seront lus
Do While nf <> "" And nf <> ThisWorkbook.Name
Workbooks.Open Filename:=nf
For ligne = 3 To Workbooks(nf).Sheets("Chrono").[A65000].End(xlUp).Row 'de la ligne 3 à la dernière cellule non-vide de a colonne A _
de la Feuil1 du fichier en cours de lecture
recap.Range("A" & compteur) = Left(nf, 15) ' en colonne A, indiquer les 5 premiers caractères du nom du fichier (=CP)
Workbooks(nf).Sheets("Chrono").Range("A" & ligne & "" & ligne).Copy Destination:=recap.Range("B" & compteur)
'copier, en colonne B, les données des colonnes de A à F du fichier lu
compteur = compteur + 1
Next ligne
Workbooks(nf).Close False
nf = Dir
Loop

ChDir ActiveWorkbook.Path 'Chemin par défaut=emplacement du fichier "Récap"
Set recap = ThisWorkbook.Sheets("Garanties reçues")
recap.Range("A3:F65500").Clear
compteur = 3 'puisque ligne 1 = en-têtes
nf = Dir("*.xls") 'tous les fichiers Excel (dans le chemin par défaut) seront lus
Do While nf <> "" And nf <> ThisWorkbook.Name
Workbooks.Open Filename:=nf
For ligne = 3 To Workbooks(nf).Sheets("Garanties reçues").[A65000].End(xlUp).Row 'de la ligne 3 à la dernière cellule non-vide de a colonne A _
de la Feuil1 du fichier en cours de lecture
recap.Range("A" & compteur) = Left(nf, 15) ' en colonne A, indiquer les 5 premiers caractères du nom du fichier (=CP)
Workbooks(nf).Sheets("Garanties reçues").Range("A" & ligne & "" & ligne).Copy Destination:=recap.Range("B" & compteur)
'copier, en colonne B, les données des colonnes de A à F du fichier lu
compteur = compteur + 1
Next ligne
Workbooks(nf).Close False
nf = Dir
Loop

ChDir ActiveWorkbook.Path 'Chemin par défaut=emplacement du fichier "Récap"
Set recap = ThisWorkbook.Sheets("Modif. ISO")
recap.Range("A3:F65500").Clear
compteur = 3 'puisque ligne 1 = en-têtes

nf = Dir("*.xls") 'tous les fichiers Excel (dans le chemin par défaut) seront lus
Do While nf <> "" And nf <> ThisWorkbook.Name
Workbooks.Open Filename:=nf
For ligne = 3 To Workbooks(nf).Sheets("Modif. ISO").[A65000].End(xlUp).Row 'de la ligne 3 à la dernière cellule non-vide de a colonne A _
de la Feuil1 du fichier en cours de lecture
recap.Range("A" & compteur) = Left(nf, 15) ' en colonne A, indiquer les 5 premiers caractères du nom du fichier (=CP)
Workbooks(nf).Sheets("Modif. ISO").Range("A" & ligne & "" & ligne).Copy Destination:=recap.Range("B" & compteur)
'copier, en colonne B, les données des colonnes de A à F du fichier lu
compteur = compteur + 1
Next ligne
Workbooks(nf).Close False
nf = Dir
Loop

ChDir ActiveWorkbook.Path 'Chemin par défaut=emplacement du fichier "Récap"
Set recap = ThisWorkbook.Sheets("recap MARS 10")
recap.Range("A3:F65500").Clear
compteur = 3 'puisque ligne 1 = en-têtes

nf = Dir("*.xls") 'tous les fichiers Excel (dans le chemin par défaut) seront lus
Do While nf <> "" And nf <> ThisWorkbook.Name
Workbooks.Open Filename:=nf
For ligne = 3 To Workbooks(nf).Sheets("recap MARS 10").[A65000].End(xlUp).Row 'de la ligne 3 à la dernière cellule non-vide de a colonne A _
de la Feuil1 du fichier en cours de lecture
recap.Range("A" & compteur) = Left(nf, 15) ' en colonne A, indiquer les 5 premiers caractères du nom du fichier (=CP)
Workbooks(nf).Sheets("recap MARS 10").Range("A" & ligne & "" & ligne).Copy Destination:=recap.Range("B" & compteur)
'copier, en colonne B, les données des colonnes de A à F du fichier lu
compteur = compteur + 1
Next ligne
Workbooks(nf).Close False
nf = Dir
Loop

ChDir ActiveWorkbook.Path 'Chemin par défaut=emplacement du fichier "Récap"
Set recap = ThisWorkbook.Sheets("recap Jany FEVRIER 10")
recap.Range("A3:F65500").Clear
compteur = 3 'puisque ligne 1 = en-têtes

nf = Dir("*.xls") 'tous les fichiers Excel (dans le chemin par défaut) seront lus
Do While nf <> "" And nf <> ThisWorkbook.Name
Workbooks.Open Filename:=nf
For ligne = 3 To Workbooks(nf).Sheets("recap Jany FEVRIER 10").[A65000].End(xlUp).Row 'de la ligne 3 à la dernière cellule non-vide de a colonne A _
de la Feuil1 du fichier en cours de lecture
recap.Range("A" & compteur) = Left(nf, 15) ' en colonne A, indiquer les 5 premiers caractères du nom du fichier (=CP)
Workbooks(nf).Sheets("recap Jany FEVRIER 10").Range("A" & ligne & "" & ligne).Copy Destination:=recap.Range("B" & compteur)
'copier, en colonne B, les données des colonnes de A à F du fichier lu
compteur = compteur + 1
Next ligne
Workbooks(nf).Close False
nf = Dir
Loop
End Sub

ça marche très bien.mais.....

1 - quand je clique sur mon bouton "rassembler tout" ça m'ouvre le premier fichier excel situé dans mes documents.(et bien sur ça bloque tout) Pour que ça marche je suis obligé à chaque fois d'enregistrer le fichier récap dans mon dossier d'origine. Comment corriger ça pour qu'il ouvre les classeurs qui sont dans le même dossier sans l'obligation d'enregisrer le ficher a chaque fois.
2 - j'ai recopier la macro autant de fois que j'avais de feuilles en les nommant à chaque fois. Je voudrais faire les modifs nécessaires pour que ça marche automatiquement avec un nombre N de classeurs tous identiques
et là bien sur j'ai besoin d'aide.
Le tout sera utilisé avec office 2007 voire office 2010
Avec tous mes remerciements.

 

[bientot50]

Re : synthèse de x fichiers excel

Bonsoir à tous
Pour résoudre mon problème 1 :
j'ai mis mon dossier Vero dans "mes documents" et là ça va bien chercher les fichiers excel du dossier Vero.
Par contre si je mets mon dossier Vero sur le bureau, ça m'ouvre le premier fichier excel de mon dossier "mes documents". Mais bon, bidouillage pour bidouillage, ça marche même si je n'ai pas compris le pourquoi du comment.
Par contre j'aimerais bien de l'aide pour faire la fusion de N fichiers, sans être obligé de recopier la macro N fois, comme je l'ai fait.
Je pense que la macro peut-être énormément simplifiée, mais lorsque j'y touche plus rien ne marche.
Merci.

 

[PMO2]

Re : synthèse de x fichiers excel

Bonjour,

J'ai inséré une première ligne dans les feuilles Modif. ISO de tous les 4 classeurs source pour être en cohérence avec les autres feuilles qui comportent les 2 premières lignes à ne pas traiter par la macro.

Essayez le code suivant à copier dans un module standard du classseur Recap.xls
1) la macro demande de fournir le dossier contenant les classeurs source
2) les noms des feuilles du classeur Recap.xls doivent correspondre aux noms des feuilles des classeurs source

Sub Regrouper_pmo()
Dim WBrecap As Workbook
Dim WB As Workbook
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim Chemin$
Dim var
Dim k&
Dim A$
Chemin$ = ChoisirDossier
If Chemin$ = "" Then Exit Sub
var = myFiles(Chemin$)
If TypeName(var) <> "Variant()" Then
  MsgBox "Aucun classeur n'a été trouvé"
  Exit Sub
End If
Set WBrecap = ThisWorkbook
For Each S In WBrecap.Worksheets
  Set R = S.UsedRange.Offset(1, 0)
  R.Clear
Next S
Application.ScreenUpdating = False
For k& = 1 To UBound(var)
  Set WB = GetObject(Chemin$ & "\" & var(k&))
    For Each S2 In WB.Worksheets
      For Each S In WBrecap.Worksheets
        If S.Name = S2.Name Then
          Set R = S2.UsedRange.Offset(2, 0)
          R.Copy Destination:=S.Range("B" & S.[a65536].End(xlUp).Row + 1 & "")
          Set R = S.Range(S.Cells(S.[a65536].End(xlUp).Row + 1, 1), _
                        S.Cells(S.[b65536].End(xlUp).Row, 1))
          A$ = Mid(var(k&), 12)
          A$ = Mid(A$, 1, InStr(1, A$, ".") - 1)
          R = A$
          Exit For
        End If
      Next S
    Next S2
  WB.Close SaveChanges:=False
  Set WB = Nothing
Next k&
Application.ScreenUpdating = True
MsgBox "Terminé"
End Sub

Private Function ChoisirDossier(Optional dummy As Byte) As String
Dim objShell
Dim objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionnez un Dossier", &H1&)
On Error GoTo Erreur
ChoisirDossier = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
Exit Function
Erreur:
ChoisirDossier = ""
End Function

Private Function myFiles(FileName) As Variant
Dim FSO
Dim FileItem
Dim A$
Dim i&
Dim T()
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each FileItem In FSO.GetFolder(FileName).Files
  A$ = UCase(Mid(FileItem, InStrRev(FileItem, ".") + 1))
  If A$ = "XLS" Or A$ = "XLSX" Or A$ = "XLSM" Then
    i = i& + 1
    ReDim Preserve T(1 To i&)
    T(i&) = FileItem.Name
  End If
Next FileItem
If i& = 0 Then
  myFiles = 0
Else
  myFiles = T
End If
Set FileItem = Nothing
Set FSO = Nothing
End Function

Je ne mets pas de pièces jointes car je suis limité à 48 ko.
Eventuellement, je peux vous les envoyer directement à votre adresse perso. Pour cela faites moi signe.

Cordialement.

PMO
Patrick Morange

 

[bientot50]

Re : synthèse de x fichiers excel

Merci Patrick

Je reviens juste aujourd'hui et je n'ai donc pas pu voir ton message avant. Je regarderais tout ça et je te tiendrai au courant. En attendant un grand grand merci.

Alain

 

[bientot50]

Re : synthèse de x fichiers excel

Bonjour Patrick

J'ai fait pleins d’essais avec ta macro après avoir rajouté une ligne dans la feuille Modif.ISO
Ca marche impeccable sous 2003.
Sous 2007 ça marche aussi très bien mais..... (à mon avis un bug d'office 2007 parce que ça ne le fait pas toujours)
quelque fois j'ai un message :
"Excel ne put pas terminer cette tâche avec les ressources disponibles. Sélectionner moins de données ou fermez des applications"
alors que je n'ai absolument rien d'ouvert. Je clique sur OK. Quelque fois le message revient encore , mais au final il fait le boulot demander et j'ai le message "terminé" qui s'affiche.
J'ai remarqué :
- qu'il ne faut surtout pas que le classeur recap soit dans le même dossier que les fichiers à récapituler
- qu'il ne faut pas qu'il y ait de ligne vide dans la colonne A de chaque feuille autrement le traitement s’arrête à la première celllule vide et il passe à un autre fichier, donc ca ne prend pas en compte toutes les lignes après la cellule vide.
Normalement il ne devrait pas y avoir de cellules vides mais bon errare humanum est paraît il.

Bref Tout marche parfaitement. Maintenant pour moi l'important est d'essayer de comprendre chaque ligne de ta macro.
Je te remercie beaucoup de ton travail et je te souhaite une bonne journée.
Merci encore
Alain