Copie des feuilles de tous les classeurs d'un répertoire dans 1 seul classeur

[ouskel'n'or]

Copie les feuilles de calculs dans un seul classeur.
Deux options :
- Copier les seules valeurs et le format (ce code)
- Copier également les formules et les liens : voir la remarque en fin de code

Tient compte des feuilles protégées. Deux possibilités :
- Protection sans mot de passe : Déprotège la feuille pour la copie des seules valeurs (macro Copie)
- Protection avec mot de passe : Génère une erreur récupérée et un message collectant nom du classeur et de la feuille. Ce message n'apparaîtra qu'en fin de macro (Appel)

Tient compte des classeurs ayant une macro Auto_Open ou Workbook_Open
Les macros sont désactivées le temps de l'ouverture (macro Ouvrir)

Tiens compte également les événements relatifs aux feuilles de calculs (macro Copie) (non testé)

Enfin, restait un éventuel problème de mémoire réglé par un compteur des feuilles copiées avec enregistrement périodique de ThisWorkbook. Ici placé à 200 feuilles, à ajuster selon les besoins (Macro Copie)

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

Remarque : Pour conserver les formules, supprimer les trois lignes (macro Copie)

If ActiveSheet.Protect = True Then ActiveSheet.Unprotect
ActiveSheet.UsedRange.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues

Les événements liés aux feuilles de calculs n'ont pas été testés.