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