compiler classeurs excel

stephblit

XLDnaute Nouveau
:) Bjr à tous,

j ai une centaine de classeurs excel dans un répertoire de mon ordinateur : C:\Users\Alex\Desktop\Nouveau dossier

Je souhaiterai compiler (fusionner) tous ces classeurs sous un seul et même fichier excel

Je pense que le code ne doit pas être bien compliqué, mais je bute dessus depuis ce matin

pouvez vous m'aider ? :eek:
 

stephblit

XLDnaute Nouveau
Re : compiler classeurs excel

Merci encore de ta contribution, mais les fichiers excel n'ont rien en commun.
Ces codes ne peuvent donc pas m'aider

En fait je vais essayer de t'expliquer mieux la chose

J'ai un dossier (C:\Users\Alex\Desktop\Nouveau dossier) à l'intérieur duquel j'ai 140 classeurs excel portant des noms différents (ex : premiere.xls, huiles.xls, test.xls,...)
Tous ces classeurs n'ont en fait qu'un point commun, ils comportent une seule feuille.

Je souhaite donc intégrer dans un nouveau classeur, sous une même feuille, l'ensemble de ces classeurs.

En espérant avoir été clair:rolleyes:
 

Staple1600

XLDnaute Barbatruc
Re : compiler classeurs excel

Re


Je disais bien :
Alors peut être en adaptant ce code à ton besoin
adaptant pouvant se comprendre comme

s'inspirant ou modifiant.

Pas eu le temps d'adapter entitèrement ce jour

Voilà un début d'ébauche
Code:
Sub adaptation_I()
'inspiré de : GetAllWorksheetNames ( de Dave Hawley)
'repris de ma réponse à ce post:
'http://www.excel-downloads.com/forum/88609-faire-dun-classeur-multifeuille-plusieur-classeur-monofeuille.html
Dim i As Integer
Dim Fin As Long
Dim Classeur_Dossier As Workbook
Dim Feuille As Worksheet
Dim Chemin As String
  
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
     
On Error Resume Next
Chemin = " C:\Users\Alex\Desktop\Nouveau dossier\"
Application.ScreenUpdating = False
If Chemin = vbNullString Then Exit Sub
With Application.FileSearch
        .NewSearch
        .LookIn = Chemin
        .FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
      
        Set Classeur_Dossier = Workbooks.Open(.FoundFiles(i))
    
            For Each Feuille In Classeur_Dossier.Worksheets
[B]Ici code à ajouter[/B]
             Next Feuille
        Classeur_Dossier.Close SaveChanges:=False
        Next i
End If
End With
     
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : compiler classeurs excel

Re

Dans chaque feuille à copier, la plage de cellules est-elle identique?

Exemple: il faut copier les cellules A1:A10 de la feuille unique de tes 140 classeurs
dans un seule feuille de ton classeur destination à savoir:
Classeur1/Feuille1/A1:A10
dans classeur Destination/FeuilleCopie/A1:A10
Classeur2/Feuille1/A1:A10
dans classeur Destination/FeuilleCopie/A11:A21

etc etc... ?
Dans ce cas en ajoutant les lignes ci-dessous
Code:
Fin = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row
'ici adpater la la cellule de recopie si besoin
Feuille.Range("A1:10").Copy ThisWorkbook.Sheets(1).Range("A" & Fin)
à la place de Ici code à ajouter dans le code fourni dans mon précédent message
on obtient bien ce que:
Je souhaite donc intégrer dans un nouveau classeur,
sous une même feuille, l'ensemble de ces classeurs.
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : compiler classeurs excel

Re

Ce code aussi fonctionne chez moi:

Il copie la plage A1:A10 de la feuille 1 de chaque classeur trouvé dans le répertoire
indiqué (ici c:\tempo)

Donc en adaptant à tes souhaits ca devrait le faire, non?

Code:
Sub parcours_rep_copie_fic()
Dim N As Long
Dim Chemin As String
Dim Fin As Long
Dim W_BK As Workbook
'ICI METTRE le nom de ton répertoire
Chemin = "c:\tempo\"
DoEvents
Application.ScreenUpdating = False
Set W_BK = ThisWorkbook
With Application.FileSearch
    .LookIn = Chemin
    .FileType = msoFileTypeExcelWorkbooks
    '.Filename = "*.xls" 'ici mettre le début du nom de tes fichiers identiques
    .SearchSubFolders = False
          On Error Resume Next
          If .Execute > 0 Then
            For N = 1 To .FoundFiles.Count
            Fin = W_BK.Sheets("Feuil1").[A65536].End(xlUp).Row + 1
                Workbooks.Open (.FoundFiles(N))
                   
                    With ActiveWorkbook
                         'ici la recopie se fait sur la feuille 1, changer le nom si besoin
                        .Sheets("Feuil1").Range("A1:A10").Copy W_BK.Sheets("Feuil1").Cells(Fin, 1)
                        .Close False
                    End With
                   
                Next N
          End If
End With
Application.ScreenUpdating = True
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
312 229
Messages
2 086 424
Membres
103 206
dernier inscrit
diambote