Discussion :

[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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
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.

[ouskel'n'or]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Public msg As String
 
Sub Appel() 'A ADAPTER
Dim Chemin As String
    Application.ScreenUpdating = False
        Chemin = "D:\xls\Test\"
        Ouvrir Chemin
    Application.ScreenUpdating = True
    If msg <> "" Then _
    MsgBox "Pour des raisons de protection ou autres, n'ont pu être copiées " & vbCrLf & msg
End Sub

Ouverture des classeurs d'un répertoire donné

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Ouvrir(Chemin As String)
Dim NomFich As String
Dim CL2 As Workbook 'fichier copié
    Application.DisplayAlerts = False 'Evite les messages d'Excel
    'Evite l'exécution éventuelle de macros liées aux fichiers ouverts
    Application.EnableEvents = False
        NomFich = Dir(Chemin & "*.xls")
        If NomFich = "" Then
             MsgBox "Aucun fichier trouvé dans " & Chemin
             Exit Sub
        End If
        Do While NomFich <> ""
            Set CL2 = Workbooks.Open(Chemin & NomFich)
            DoEvents
            Copie CL2
            CL2.Close False
            DoEvents
            ThisWorkbook.Save 'enregistrement du classeur après chaque copie
            DoEvents
            NomFich = Dir
        Loop
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

Copie à la suite, dans une feuille unique, des données de toutes les feuilles du classeur CL2

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Copie(CL2 As Workbook)
Dim LaFeuille As Worksheet, FL1 As Worksheet, derlig as long
    Set FL1 = ThisWorkbook.Worksheets("feuil1") 'feuille où les données sont collées
    For Each LaFeuille In CL2.Worksheets 'parcours du classeur à copier
        'On vérifie que la feuille n'est pas vide
        If Not (LaFeuille.UsedRange.Address = "$A$1" And Range("A1") = "") Then
            DerLig = FL1.Range("A" & Rows.Count).End(xlUp).Row + 1 'première ligne vide
            On Error Resume Next
            LaFeuille.UsedRange.Copy FL1.Cells(DerLig, 1)
            DoEvents
            If Err <> 0 Then
                msg = msg & "Classeur " & NomFich & " feuille " & LaFeuile.Name & vbCrLf
                On Error GoTo 0
            End If
        End If
    Next
End Sub

La gestion d'erreur est une simple précaution. Utile pour la copie de feuilles complètes en cas de protection, pas nécessairement pour la copie des seules données (?)