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
40
41
42
43
44
45
46
47
| Option Explicit
Sub MainExport()
Dim Folder As String, FileList() As String, Elem As Long
Dim wkb1 As Workbook, ShtFrom As Worksheet
Dim txt As String
' Sélection du répertoire
Folder = GetFolder(ThisWorkbook.Path & "\"): If Len(Folder) = 0 Then Exit Sub
txt = "Nombre de lignes importées"
' Renvoie la liste des fichiers présent dans le répertoire (Folder)
FileList = FileListInFolder(Folder)
Application.ScreenUpdating = False
For Elem = 0 To UBound(FileList)
Set wkb1 = Workbooks.Open(Folder & FileList(Elem))
Set ShtFrom = wkb1.Worksheets(3)
Select Case Elem
Case 0: txt = txt & vbCrLf & wkb1.Name & " - " & ExportTable(ShtFrom, shtExport, ClearSheet:=True) & " lignes"
Case Else: txt = txt & vbCrLf & wkb1.Name & " - " & ExportTable(ShtFrom, shtExport) & " lignes"
End Select
wkb1.Close
Next
MsgBox txt, Title:="Importation des données du répertoire " & Folder
Application.ScreenUpdating = True
End Sub
Function GetFolder(Optional StrPath As String) As String
Dim fdlg As FileDialog, sItem As String
Set fdlg = Application.FileDialog(msoFileDialogFolderPicker)
If Len(StrPath) = 0 Then StrPath = Application.ActiveWorkbook.Path & "\"
With fdlg
.Title = "Selection d'un répertoire"
.AllowMultiSelect = False
.InitialFileName = StrPath
If .Show = -1 Then GetFolder = .SelectedItems(1)
End With
Set fdlg = Nothing
End Function
Function FileListInFolder(StrPath As String) As Variant
Dim FileName As String, Elem As Long, FileList() As String
If Right(StrPath, 1) <> "\" Then StrPath = StrPath & "\"
FileName = Dir(StrPath)
Do While FileName <> ""
If Right(FileName, 4) = ".xls" Then
ReDim Preserve FileList(Elem): FileList(Elem) = FileName: Elem = Elem + 1
End If
FileName = Dir
Loop
FileListInFolder = FileList
End Function |
Concaténer 1er onglet de plusieurs classeurs différents
Répondre avec citation
et quand la discussion est résolue, penser à cliquer sur le bouton 
Envoyé par BENNASR
Partager