Compiler plusieurs fichiers excel
Résolu/Fermé
saracino
Messages postés
2
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
11 août 2010
-
10 août 2010 à 13:32
pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 - 12 août 2010 à 19:14
pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 - 12 août 2010 à 19:14
A voir également:
- Compiler plusieurs fichiers excel
- Liste déroulante excel - Guide
- Formule excel pour additionner plusieurs cellules - Guide
- Renommer plusieurs fichiers - Guide
- Si et excel - Guide
- Fusionner plusieurs fichiers excel - Guide
1 réponse
pijaku
Messages postés
12263
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
4 janvier 2024
2 750
11 août 2010 à 10:01
11 août 2010 à 10:01
Salut,
Je t'ai trouvé : ici la macro dont tu as besoin :
Rassembler tous les classeurs d'un répertoire, dans un classeur
Ne l'ayant pas testé, il est possible que cela ne fonctionne pas exactement comme tu le souhaites. Si tel est le cas, n'hésite pas nous complèterons cette réponse....
Je t'ai trouvé : ici la macro dont tu as besoin :
Rassembler tous les classeurs d'un répertoire, dans un classeur
---- Exécuter la procédure Appel ----
Public msg As String, Cpt as Integer
Sub Appel()
Dim FL1 As Workbook, Chemin As String
Application.ScreenUpdating = False
Chemin = "D:\xls"
Set FL1 = ThisWorkbook
Ouvrir Chemin, FL1
Application.ScreenUpdating = True
MsgBox "Pour des raisons de protection ou autres, n'ont pu être copiées " & vbCrLf & msg
End Sub
---- Ouverture des fichiers ----
Sub Ouvrir(Chemin As String, FL1 As Workbook)
Dim NomFich As String
NomFich = Dir(Chemin & "\")
If NomFich = "" Or Right(NomFich, 4) <> ".xls" Then
MsgBox "Aucun fichier trouvé dans " & Chemin & "."
Exit Sub
End If
Do While NomFich <> ""
Application.EnableEvents = False
Workbooks.Open Chemin & "\" & NomFich
DoEvents
Application.EnableEvents = True
NomFich = ActiveWorkbook.Name
Copie NomFich, FL1
NomFich = Dir
Loop
End Sub
---- Copie des feuilles ----
Sub Copie(NomFich As String, FL1 As Workbook)
Application.EnableEvents = False
For Each LaFeuille In Workbooks(NomFich).Worksheets
'MsgBox LaFeuille.Name
On Error Resume Next
LaFeuille.Copy After:=FL1.Sheets(FL1.Sheets.Count)
DoEvents
If ActiveSheet.Protect = True Then ActiveSheet.Unprotect
ActiveSheet.UsedRange.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
If Err <> 0 Then
msg = msg & "Classeur " & NomFich & " feuille " & LaFeuile.Name & vbCrLf
Err.Clear
On Error GoTo 0
End If
DoEvents
If Cpt Mod 200 = 0 Then
ThisWorkbook.Save
DoEvents
End If
Next
Application.EnableEvents = True
'Fermeture du classeur
Application.DisplayAlerts = False
Workbooks(NomFich).Close False
Application.DisplayAlerts = True
DoEvents
End Sub
Ne l'ayant pas testé, il est possible que cela ne fonctionne pas exactement comme tu le souhaites. Si tel est le cas, n'hésite pas nous complèterons cette réponse....
Modifié par saracino le 11/08/2010 à 17:22
Déjà je te remercie pour la rapidité de ta réponse...
Surement que cette macro marche, mais moi qui n'y connait rien au langage Visual Basics => je comprends juste les macros répétitives très simples...Est-il possible qu'on me le mette directement dans un document excel?
Merci beaucoup,
Matthieu
Modifié par pijaku le 12/08/2010 à 08:48
pas eu le temps hier soir...
J'ai modifié la procédure d'appel grâce à l'astuce de lermitte222. Cela donne :
'---- Exécuter la procédure Appel ---- Sub Appel() Dim FL1 As Workbook, Chemin As String Const ssfTous = &H1 Dim objShell As Object, objFolder As Object, oFolderItem As Object Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", ssfTous) Set oFolderItem = objFolder.Items.Item Chemin = oFolderItem.Path Set objShell = Nothing Set objFolder = Nothing Set oFolderItem = Nothing Application.ScreenUpdating = False Set FL1 = ThisWorkbook Ouvrir Chemin, FL1 Application.ScreenUpdating = True If msg = "" Then MsgBox "Copie des fichiers terminée, sans souci." Else MsgBox "Pour des raisons de protection ou autres, n'ont pu être copiés :" & vbCrLf & msg End If End SubEt voici le classeur test pour essai...
N'hésite pas
12 août 2010 à 17:43
Je te remercie énormément! cela fonctionne parfaitement!
Tu deviens ainsi mon idole ;-).
Je plaisante mais cela me rend énormément service pour mon travail.
Pour savoir faire ce genre de chose, faut-il avoir un très bon niveau en macro?
Merci encore,
Matthieu
12 août 2010 à 19:14