Bonjour,
Je suis sur XL2007, et cherche à récupérer toutes les premières feuilles des classeurs d'un répertoire dans un nouveau classeur, votre code m'intéresse beaucoup, et au passage, merci de l'avoir posté.

Je pense que dans mon cas, l'adaptation se fait au niveau de ce module :

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
J'ai tenté de le modifier de la manière suivante, mais je ça bloque sur la ligne
Code : Sélectionner tout - Visualiser dans une fenêtre à part
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
Avec un message d'erreur 1004 sur une incompatibilité de zone copier et zone coller.

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
29
30
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
'partie modifiée
            Workbooks(NomFich).Sheets(1).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

Merci pour votre aide.

Cordialement,