Recherche de fichier dans plusieurs dossiers
Bonjour,
Je cherche à faire des calculs de statistiques sur plusieurs fichiers excel.
Pour cela, je dois trouver, à partir d'un dossier source, un fichier dont le nom est "data1_appareilX" qui se trouve dans un sous-dossier, et un fichier dont le nom est "data2_appareilX" qui se trouve dans un sous-dossier. De plus, je dispose de plusieurs appareils, et comme je débute dans le VBA je galère un peu.
Une fois que je dispose de ces fichiers, je dois en extraire certaines données, et les mettre dans un nouveau classeur (dans mon programme, ce sera sur la feuille "Data")
Sur l'image, je résume ce que j'ai essayé de vous expliquer.
Pour l'instant, mon programme me permet d'extraire les données de 4 fichiers que j'ai mis dans un même dossier. Cependant, comme je dispose d'un nombre très important d'appareils qui ne sont pas sensé être dans le même dossier, j'aimerais automatiser cela.
Sub main()
'Variable
Dim filePath As String
Dim data1(50) As String
Dim Fdata2(50) As String
Dim nbFiles As Integer
nbFiles = 2
'Begin
ThisWorkbook.Activate
Set shtData = Worksheets("Data")
Set shtMain = Worksheets("Accueil")
filePath = "D:\Users\Documents\"
data1(1) = "data1_app1.xls"
data1(2) = "data1_app2.xls"
data2(1) = "data2__app1.xls"
data2(2) = "data2_app2.xls"
'ClearContents
Sheets("Data").Cells.Clear
Sheets("Feuil4").Cells.Clear
'Titre tests
'Extraction des données
Call Conso_ext(data1, nbFiles)
Call Power_ext(data1, nbFiles)
Call Trans_ext(data2, nbFiles)
End Sub
Sub Conso_ext(data1, nbFiles)
Dim i As Integer
For i = 1 To nbFiles
ThisWorkbook.Names.Add "plage", _
RefersTo:="='" & filePath & "[" &data1(i) & "]1'!$E$15:$G$15"
With Sheets("Feuil4")
.[E15:G15] = "=plage"
.[E15:G15].Copy
Sheets("Data").Range("B" & i + 1).PasteSpecial xlPasteValues
.[E15:G15].Clear
End With
Next
End Sub
Sub Power_ext(data1, nbFiles)
Dim i As Integer
For i = 1 To nbFiles
ThisWorkbook.Names.Add "plage", _
RefersTo:="='" & filePath & "[" & data1(i) & "]1'!$E$34:$G$34"
With Sheets("Feuil4")
.[E34:G34] = "=plage"
.[E34:G34].Copy
Sheets("Data").Range("E" & i + 1).PasteSpecial xlPasteValues
.[E34:G34].Clear
End With
Next
End Sub
J’ai trouvé une réponse qui me semble proche de ce que je cherche sur le forum (ici: https://forum.excel-pratique.com/excel/vba-ouvrir-fichier-excel-particulier-dans-plusieurs-dossiers-...)
Cependant, comme je ne comprend pas totalement, je n’arrive pas à l’intégrer à ma macro.
Quelqu’un aurait une petite idée svp?🥺
Bonjour,
Voici un proto-essai avec un grand vide sur la partie manipulation de fichier après ouverture...
Ici, on récupère les répertoires de tous les sous-dossiers de SOURCE. Puis, pour chacun de ces dossiers obtenus, on récupère dans un autre tableau tous les sous-dossiers qu'il contient. Quand ce dossier n'en contient pas, on garde uniquement le répertoire du sous-dossier final.
Ensuite, on parcourt tous les répertoires finaux pour y chercher et y ouvrir, le cas échéant, les fichiers commençant par "data".
Ce n'est pas testé. Il faudra peut-être déclarer des variables. Il faudra peut-être modifier la seconde dimension du tableau arrSubfolders et il faudra certainement adapter le chemin du dossier SOURCE :
Sub test()
dim arrSubfolders()
strPath = "C:\Source\"
'TABLEAU CONTENANT LES DOSSIERS DE SOURCE
arrFolders = ListeDossiers(strPath)
redim arrSubfolders(1 to ubound(arrFolders), 1 to 100)
'TABLEAU CONTENANT TOUS LES SOUS-DOSSIERS ou, à défaut, LES DOSSIERS SANS SOUS-DOSSIER
For i = LBound(arrFolders) To UBound(arrFolders)
strFolder = dir(arrFolders(i), vbdirectory)
while strFolder <> "" then
if not strFolder like "*.*" then
k = k + 1
arrSubfolders(i, k) = arrFolders(i) & strFolder & "\"
end if
strFolder = Dir
wend
if k = 0 then arrSubfolders(i, 1) = arrFolders(i) else k = 0
Next i
'PARCOURT TOUS LES REPERTOIRES "FINAUX" ET OUVRE CHAQUE FICHIER "data..." s'y trouvant
For i = LBound(arrSubfolders) To UBound(arrSubfolders)
For k = LBound(arrSubfolders, 2) To UBound(arrSubfolders, 2)
if arrSubfolders(i, k) <> "" then
strCurrentFile = Dir(arrSubfolders(i, k) & "data*.xls*")
While strCurrentFile <> ""
set wb = workbooks.open(arrSubfolders(i,k) & strCurrentFile)
with wb
'code a executer dessus
.close true
end with
strCurrentFile = Dir
Wend
end if
Next k
Next i
End Sub
Function ListeDossiers(strRepertoire$)
Dim strDossier$, n&, temp()
strDossier = Dir(strRepertoire, vbDirectory)
While strDossier <> ""
If Not strDossier Like "*.*" Then
ReDim Preserve temp(n)
temp(n) = strRepertoire & strDossier & "\"
n = n + 1
End If
strDossier = Dir
Wend
ListeDossiers = temp
End FunctionCdlt,