Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Public msg As String
 
Sub Appel() 
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

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


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

Sheets("Feuil1").Range("A65536").End(xlUp).Row

Sub test()
Application.DisplayAlerts = False
Chemin = "C:\Documents and Settings\Administrateur\Bureau\Nouveau dossier\"
Fichier = Dir(Chemin & "Copie*")
Do While Fichier <> ""
Workbooks.Open Filename:=Chemin & Fichier
For i = 1 To Sheets.Count
Cells.Select
Selection.Copy

Workbooks(Fichier).Activate
Windows("Classeur1.xls").Activate
'Workbooks("Classeur1.xls").Range("A65536").End(xlUp).Row
Sheets("Feuil1").Range("A65536").End(xlUp).Row

ActiveSheet.Paste
Next i
Workbooks(Fichier).Close SaveChanges:=False
Fichier = Dir
Loop
Application.DisplayAlerts = True
End Sub

Sheets("Feuil1").Range("A65536").End(xlUp).Row

Option Explicit

Sub Tst()
Dim i As Long
    i = Sheets("Feuil1").Range("A65536").End(xlUp).Row
    Debug.Print i
End Sub

Option Explicit

Sub Tst()
Dim dlgn As Long
    dlgn = Sheets("Feuil1").Range("A65536").End(xlUp).Row
    Debug.Print dlgn
End Sub

Sub test()
Dim Chemin As String
Dim Fichier As String
Dim i As Long

Application.DisplayAlerts = False
Chemin = "C:\Documents and Settings\Administrateur\Bureau\Nouveau dossier\"
Fichier = Dir(Chemin & "*.xls")
Do While Fichier <> ""

For i = 1 To Sheets.Count
Workbooks.Open Filename:=Chemin & Fichier
Worksheets("Référencement").Activate
Cells.Select
Selection.Copy

Workbooks(Fichier).Activate
Windows("Macro Assembler plusieurs fichiers.xlsm").Activate

Tst
ActiveSheet.Paste

Workbooks(Fichier).Close SaveChanges:=False
Fichier = Dir
Next i
Loop
Application.DisplayAlerts = True
End Sub