1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
| Sub test()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook
Dim dl As Long, wbdl As Long, wbdc As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = ThisWorkbook.Sheets("to do").Range("chemin")
'supression si demandé des données de la feuille data
If ThisWorkbook.Sheets("to do").Range("supr") = "Oui" Then ThisWorkbook.Sheets("data").Cells.ClearContents
'boucle sur les fichiers
For Each f1 In Fso.GetFolder(MonRepertoire).Files
If f1.Name Like "*.xlsx" Then
Set wb = Workbooks.Open(f1)
dl = ThisWorkbook.Sheets("data").Range("A" & Rows.Count).End(xlUp).Row
If dl = 1 Then
wb.Sheets(1).Cells(1, 1).CurrentRegion.Copy
ThisWorkbook.Sheets("data").Cells(dl, 1).PasteSpecial xlValues
Application.CutCopyMode = False
wb.Close
Else
If ThisWorkbook.Sheets("to do").Range("entete") = "Non" Then
wb.Sheets(1).Cells(1, 1).CurrentRegion.Copy
ThisWorkbook.Sheets("data").Cells(dl + 1, 1).PasteSpecial xlValues
Application.CutCopyMode = False
wb.Close
Else
wbdl = Range("A" & Rows.Count).End(xlUp).Row
wbdc = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 1), Cells(wbdl, wbdc)).Copy
ThisWorkbook.Sheets("data").Cells(dl + 1, 1).PasteSpecial xlValues
Application.CutCopyMode = False
wb.Close
End If
End If
End If
Next f1
End Sub |
Partager