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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
| Option Explicit
Sub Module01ConcatenerRépertoire()
'................................................................................................................
'Declaration des variables
Dim Classeur_Maitre As Workbook, Classeur_Slave As Workbook
Dim oShell As Object, oFolder As Object
Dim oFolderItem As Object
Dim Tab_Files As Variant
Dim aFile As Variant
Dim ValueB7 As String 'si le contenu de la cellule B7 est numerique mettre Long ou integer a la place de string
Dim Cel As Range
Application.DisplayAlerts = False
Set Classeur_Maitre = ActiveWorkbook
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
If oFolder Is Nothing Then
MsgBox "Abandon opérateur", vbCritical
Exit Sub
Else
Set oFolderItem = oFolder.Self
'MsgBox oFolderItem.Path
End If
'Fin du morceau pioché
'On recupert les fichier contenu dans le repertoire en question
Tab_Files = ListFilesInFolder(oFolderItem.Path, False) 'mettre true a la place de false pour regarder les sous repertoires et rajouter une liste d'extension pour limiter les fichiers listés (,"txt;ert;doc;xls")
For Each aFile In Tab_Files
'................................................................................................................
Set Classeur_Slave = Workbooks.Open(aFile, ReadOnly:=True) 'adapte ton code
'Ouvre classeur Slave sheet 1 et copie la cellule 'adapte ton code
Classeur_Slave.Sheets("Celle que tu veux").Select 'adapte ton code
Classeur_Slave.Sheets("Celle que tu veux").Range("A1:AA2").Copy 'adapte ton code
'Copie du classeur Slave et le colle en collage spécial valeurs dans le Classeur Maitre de la sheets 2 'adapte ton code
With Classeur_Maitre.Sheets(2).Range("A65536").End(xlUp) 'adapte ton code
'.Offset(1, 0).Value = Classeur_Slave.Name 'adapte ton code
.Offset(2, 0).PasteSpecial Paste:=xlValues 'colle à la 2è ligne vers le bas 'adapte ton code
End With
'...................................................................................................................
Classeur_Slave.Close False
Next
End Sub
Function ListFilesInFolder(strFolderName As String, Optional bIncludeSubfolders As Boolean = False, Optional strTypeFichier As String) As Variant
'
' necessite d'activer la reference Microsoft Scripting RunTime par VBA Outils Références cocher Microsoft Scripting RunTime
'
Static FSO As FileSystemObject
Static bNotFirstTime As Boolean
Static tabType As Variant, vType As Variant
Static dicoType As Object
Static strResult As String
Dim bTheFirst As Boolean
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.File
'Static wksDest As Worksheet
'Static iRow As Long
'initialisation
bTheFirst = False
If Not bNotFirstTime Then
'On identifie le tout premiere appel de la fonction recursive
bTheFirst = True
Set FSO = CreateObject("Scripting.FileSystemObject")
Set dicoType = CreateObject("Scripting.Dictionary")
If strTypeFichier <> "" Then
'On cré un tableau contenant toutes les extensions / * si rien de precisé
tabType = Split(strTypeFichier, ";")
' a l'aide de ce tableau on renseigne notre dictionnaire
For Each vType In tabType
dicoType.Add vType, "Ext"
Next
End If
bNotFirstTime = True
On Error Resume Next
Set oSourceFolder = FSO.GetFolder(strFolderName)
On Error GoTo 0
'On regarde si le rep existe bien
If oSourceFolder Is Nothing Then
MsgBox "Le répertoir '" & strFolderName & "' n'existe pas." & vbCrLf & "L'execution va prendre fin.", vbExclamation, "Répertoir inconnu"
GoTo finApp
End If
End If
Set oSourceFolder = FSO.GetFolder(strFolderName)
'On boucle sur tous les fichier present
For Each oFile In oSourceFolder.Files
'On verifie que l'extension du fichier correspond a ce qui est demandé
If dicoType.Exists(ExtractFileExt(oFile.Name)) Or (strTypeFichier = "") Then
'On le rajoute dans la chaine result
strResult = strResult & oFile.Path & ";"
End If
Next oFile
'Si on a l'option Sous dossier on boucle sur les sous dossiers
If bIncludeSubfolders Then
For Each oSubFolder In oSourceFolder.SubFolders
'On ajoute les fichiers contenu dans ce rep dans la liste precedente
strResult = Join(ListFilesInFolder(oSubFolder.Path, True), ";") & ";"
Next oSubFolder
End If
'On supprime le dernier ";" s'il il existe
If Right(strResult, 1) = ";" Then strResult = Left(strResult, Len(strResult) - 1)
'On renvoi le resulta sous forme de tabelau
ListFilesInFolder = Split(strResult, ";")
finApp:
'Si on se trouve dans le 1er appel on reinitialise les vaiables Static
'pour ne pas conserver des valeurs static lors d'une prochaine utilisation de la fonction
If bTheFirst Then
Set FSO = Nothing
Set dicoType = Nothing
bNotFirstTime = False
tabType = ""
vType = ""
strResult = ""
End If
End Function
Function ExtractFileExt(strName As String) As String
If InStr(strName, ".") = 0 Then
ExtractFileExt = ""
Else
ExtractFileExt = Mid(strName, InStrRev(strName, ".") + 1)
End If
End Function
'................................................................................................................................... |
