Option Explicit
Const FeuilleRep = "Feuil1" ' Nom de la feuille des répertoires à parcourir (colonne A)
Const Debut = "Source" ' Début des noms des fichiers à concaténer
Const Extension = "xlsx" ' Extension des fichiers à concaténer
Const FeuilSource = "Data" ' Nom de la feuille où sont des données à concaténer
Const LigneDébut = 9 ' Ligne de début de la zone à concaténer
Const FeuilCible = "Concat" ' Nom de la feuille destination des données (dans ce classeur)
Private ClnFichier As New Collection ' Collection des fichiers à concatéténer
Sub Concatener()
Dim Fle As File, L As Long
Application.ScreenUpdating = False
CreerCollectionFichiers
With ThisWorkbook.Sheets(FeuilCible)
.Cells.Clear
L = 1
For Each Fle In ClnFichier
ConcatUnFichier Fle, L
Next Fle
Application.Goto .Range("a1"), True
End With
MsgBox "Concaténation terminée", vbInformation
End Sub
Sub ConcatUnFichier(ByVal Fle As File, ByRef LCbl As Long)
Dim Wbk As Workbook, Wsh As Worksheet, RngSrc As Range, LFin As Long
Set Wbk = Workbooks.Open(Fle.Path)
On Error Resume Next: Set Wsh = Wbk.Worksheets(FeuilSource)
On Error GoTo 0: If Wsh Is Nothing Then MsgBox "Le classeur :" & vbLf & Wbk.FullName & vbLf & _
"ne possède pas de feuille """ & FeuilSource & """.", vbExclamation, "ConcatUnFichier": Exit Sub
LFin = Wsh.Cells(Wsh.Rows.Count, "A").End(xlUp).Row
If LFin >= LigneDébut Then
Set RngSrc = Wsh.Range(Wsh.Rows(LigneDébut), Wsh.Rows(LFin))
RngSrc.Copy ThisWorkbook.Worksheets(FeuilCible).Rows(LCbl)
LCbl = LCbl + RngSrc.Rows.Count
End If
Wbk.Close SaveChanges:=False
End Sub
Sub CreerCollectionFichiers()
Dim Cel As Range, Chemin As String, FSO As New FileSystemObject, Fdr As Folder
With ThisWorkbook.Worksheets(FeuilleRep)
For Each Cel In .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
Chemin = Cel.Value
On Error Resume Next
Set Fdr = FSO.GetFolder(Chemin)
If Err Then
MsgBox "Erreur " & Err & " en tentant d'acéder à :" & vbLf & Chemin _
& vbLf & Err.Description, vbCritical, "CréerCollectionFichiers"
End
Else: ListeFichiers Fdr, Debut & "*." & Extension: End If
Next Cel
End With
End Sub
Sub ListeFichiers(ByVal Fdr As Folder, ByVal Modèle As String) '(Récursif)
Dim SubFdr As Folder, Fle As File
For Each Fle In Fdr.Files
If LCase(Fle.Name) Like LCase(Modèle) Then ClnFichier.Add Fle
Next Fle
For Each SubFdr In Fdr.SubFolders
ListeFichiers SubFdr, Modèle
Next SubFdr
End Sub
