Regroupement Fichier

Sub Creer_Recapitulatif()
Dim sRep As String 'Répertoire ou filtre
Dim sFichier As String
Dim wb As Workbook, ws As Worksheet, rg As Range
Dim wbR As Workbook, wsR As Worksheet, rgC As Range
Dim tablo

Set wbR = ThisWorkbook 'fichier récapitulatif
Set wsR = wbR.Sheets("Recap") 'onglet récapitulatif

Application.ScreenUpdating = False
sRep = ChoisirRepertoire & "\"
'Boîte de dialogue pour choisir répertoire
sFichier = Dir(sRep)
Do While sFichier <> ""
If sFichier <> wbR.Name Then
Set wb = Workbooks.Open(sRep & sFichier) 'ouvrir le fichier
Set ws = wb.Sheets(1) 'les données se trouvent dans le 1er onglet
Set rg = ws.Range("A1").CurrentRegion 'sélection des données
tablo = rg 'mettre les données dans un tablo pour copier ensuite

wsR.Range("A65000").End(xlUp).Offset(1, 0).Resize(rg.Rows.Count, 1) = wb.Name 'nom du fichier
wsR.Range("B65000").End(xlUp).Offset(1, 0).Resize(rg.Rows.Count, 7) = tablo 'données
wb.Close savechanges:=True
End If
sFichier = Dir 'trouve le prochain fichier
Loop
Application.ScreenUpdating = True
End Sub
Function ChoisirRepertoire() As String
Dim diaFolder As FileDialog
' Ouvrir la boîte de dialog
On Error Resume Next
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.Show
ChoisirRepertoire = diaFolder.SelectedItems(1)
Set diaFolder = Nothing
End Function

Cliquez pour agrandir...