Compiler plusieurs fichiers excel

Résolu
saracino Messages postés 3 Statut Membre -  
pijaku Messages postés 13513 Statut Modérateur -
Bonjour,

j'ai un soucis Sur Excel.

Ma question est peut etre basique mais j'aimerais la réponse car j'en ai besoin pour le travail.
Voila, j'ai Soixante fichiers excel de forme identique avec à chaque fois 1 feuille toujours de forme identique.

Ces fichiers se trouvent dans le même dossier.


Connaissez-vous une macro capable de tout me copier dans un Seul fichier Excel (Les feuilles des différents fichiers dans un seul fichier excel). Je voudrais que mes différents fichiers excel deviennent un seul fichier excel mais avec autant de feuilles qu'avant...

Je vous remercie énormément pour la réponse car en fouillant sur le forum je n'ai pas trouvé ma réponse...

1 réponse

Réponse 1 / 1
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Salut,
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....
1
saracino Messages postés 3 Statut Membre
 
Bonjour,
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
0
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Salut,
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 Sub

Et voici le classeur test pour essai...
N'hésite pas
0
saracino
 
Salut,
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
0
pijaku Messages postés 13513 Statut Modérateur 2 763
 
pour écrire ce genre de macro, il faut déjà si connaître oui. Cependant, je n'ai rien écrit ici. Pas une ligne de code ne vient de moi. Dans ce cas, suffisait de comprendre un peu de vba, comment cela fonctionne et de chercher le code adapté.
0