Option Explicit
Sub ConsoliderLesClasseurs()
Dim Chemin As String, Classeur As String
Dim TousClasseurs() As String
Dim NbLign As Long, NbClasseurs As Long
Dim ClasseurDépart As Workbook
Dim FeuilleDest As Worksheet
Dim PlageDépart As Range
Dim CalcMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Si la feuille de destination n'est pas la première, adaptez
Set FeuilleDest = ThisWorkbook.Sheets(1)
' chemin du dossier contenant les Classeurs à consolider.
Chemin = "E:\www\test"
' Ajout d'un \ à la fin du chemin
If Right(Chemin, 1) <> "\" Then
Chemin = Chemin & "\"
End If
' Sortie si il n'y a pas de classeur excel dans le dossier indiqué
Classeur = Dir(Chemin & "*.xl*")
If Classeur = "" Then
MsgBox "Pas de classeur excel dans ce dossier"
GoTo SortiePropre
Exit Sub
End If
'on remplit un array (tableau VBA) avec le nom des Classeurs
NbClasseurs = 1
Do While Classeur <> ""
ReDim Preserve TousClasseurs(1 To NbClasseurs)
TousClasseurs(NbClasseurs) = Classeur
Classeur = Dir()
NbClasseurs = NbClasseurs + 1
Loop
' Boucle sur tous les classeurs stockés dans l'array
For NbClasseurs = LBound(TousClasseurs) To UBound(TousClasseurs)
'ce code est conçu pour des données se situant toujours en feuille 1
'des classeurs et commençant en A1 avec une ligne de titre
'si ce n'est pas le cas, adapter
NbLign = FeuilleDest.Range("A1").CurrentRegion.Rows.Count
Set ClasseurDépart = Workbooks.Open(Chemin & TousClasseurs(NbClasseurs))
Set PlageDépart = ClasseurDépart.Worksheets(1).Range("A1").CurrentRegion
If Not PlageDépart Is Nothing Then
If PlageDépart.Rows.Count + NbLign >= FeuilleDest.Rows.Count Then
MsgBox ("Le nombre de lignes à importer est trop important")
ClasseurDépart.Close savechanges:=False
GoTo SortiePropre
ThisWorkbook.Close savechanges:=False
Else
'on ne copie pas la première ligne du tableau
PlageDépart.Offset(1, 0).Resize(PlageDépart.Rows.Count - 1, PlageDépart.Columns.Count).Copy _
Destination:=FeuilleDest.Range("A" & NbLign + 1)
ClasseurDépart.Close savechanges:=False
End If
End If
Next NbClasseurs
SortiePropre:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub