Macro sur fichiers dans dossiers séparés

Résolu/Fermé
cletess Messages postés 38 Date d'inscription jeudi 10 janvier 2013 Statut Membre Dernière intervention 5 avril 2018 - Modifié le 19 mars 2018 à 18:24
cletess Messages postés 38 Date d'inscription jeudi 10 janvier 2013 Statut Membre Dernière intervention 5 avril 2018 - 20 mars 2018 à 15:42
Bonjour,

j'ai une liste de ~1000 dossiers comprenant tous (entre autres) un fichier 'information.xlsx'. Voir ici un exemple de 5 dossiers :



A partir du fichier test.xlsx repris dans le répertoire, je dois lister le nom de chacun de ces dossiers et pour chacun d'eux aller récupérer des données reprises dans chaque fichier information.xlsx. Je parviens à faire ces deux étapes de façon indépendante mais je n'arrive pas à les combiner.

Pour l'heure, je récupère les noms de dossiers avec cette macro :

Sub PrintFolders()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer

Application.StatusBar = ""
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\Macro_test")
i = 1
'loops through each folder in the directory and prints their names and path
For Each objSubFolder In objFolder.subfolders
Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
    'print folder name
    Cells(i + 1, 1) = objSubFolder.Name
    i = i + 1
    
Next objSubFolder
End Sub


Auriez-vous quelques piste sur comment améliorer la macro ci-dessus pour ouvrir chacun de ces dossiers et appliquer une quelconque opération sur le fichier information.xlsx ?

Je crois devoir utiliser la méthode Workbooks.Open(Path & "information.xlsx") en faisant référence à objSubFolder.Path mais je ne parviens pas à le faire.

Auriez-vous quelques indications ? Merci d'avance !!

CL




EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.
A voir également:

1 réponse

yg_be Messages postés 21095 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 février 2023 1 308
19 mars 2018 à 23:01
bonsoir, peut-être:
dim wb as workbook
set wb = Workbooks.Open(objSubFolder.Path & "\information.xlsx") 
0
cletess Messages postés 38 Date d'inscription jeudi 10 janvier 2013 Statut Membre Dernière intervention 5 avril 2018
20 mars 2018 à 11:14
Merci encore pour votre aide !

Voici à quoi j'arrive :

 Sub PrintFolders()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer

Dim Wb As Workbook
Dim strFile As String
Dim strDir As String

Dim fdest As Worksheet, fsource As Worksheet
Dim dlig As Long
Dim sfich As String
Dim srow As Range
Dim crit1$, crit2$, crit3$
Dim skey, sval, cpath As String

cpath = ThisWorkbook.Path & "\"
Set fdest = ActiveSheet
crit1 = fdest.Cells(1, 2)
crit2 = fdest.Cells(1, 3)
crit3 = fdest.Cells(1, 4)

dlig = 2

Application.StatusBar = ""
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\Macro_test\")
i = 1
'loops through each folder in the directory and prints their names and path
For Each objSubFolder In objFolder.subfolders
Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
'print folder name
strDir = objSubFolder.Path
strFile = strDir & "\informations.txt"
'Loop

Do While strFile <> ""
Set Wb = Workbooks.Open(strFile, Format:=6, Delimiter:=",")
'Save it as Excel file, same name as text file
Wb.SaveAs Left(strFile, InStrRev(strFile, ".") - 1), xlWorkbookDefault
'Done
Wb.Close
Set Wb = Nothing
Set Wb = Workbooks.Open(strDir & "\informations.xlsx")
Set fsource = Wb.Sheets(1)
For Each srow In fsource.UsedRange.Rows
skey = srow.Cells(1, 1)
sval = srow.Cells(1, 2)
Select Case skey
Case Is = crit1
fdest.Cells(dlig, 2) = sval
Case Is = crit2
fdest.Cells(dlig, 3) = sval
Case Is = crit3
fdest.Cells(dlig, 4) = sval
End Select
Next srow
Wb.Close
dlig = dlig + 1
sfich = fdest.Cells(dlig, 1)
Exit Do
Loop

Cells(i + 1, 1) = objSubFolder.Name
i = i + 1

Next objSubFolder

End Sub


En somme, je cherche à ce que la macro ouvre chaque dossier, en liste le nom, ouvre le fichier txt et le convertisse en xlsx, et extraie certaines informations des fichiers xlsx dans le fichier source.

Il me semble que ça fait ce que ça doit faire mais ça me parait (excusez moi l'expression) assez 'bordélique' comme code. J'ai un peu bidouillé différentes macro pour les combiner et je ne sais pas trop comment vérifier le travail !

Je suis forcé d'avouer que je ne suis pas une fleche en VBA alors je procède fort en essais/erreurs

Aussi, la macro est assez lente sur les ~1000 dossiers que je dois traiter. Auriez-vous des idées pour l'optimiser ?

Merci d'avance

CL
0
yg_be Messages postés 21095 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 février 2023 1 308 > cletess Messages postés 38 Date d'inscription jeudi 10 janvier 2013 Statut Membre Dernière intervention 5 avril 2018
20 mars 2018 à 13:11
est-il utile de sauver le fichier txt en xlsx?
en tous cas, moi j'essaierais, au lieu de ceci:
Set Wb = Workbooks.Open(strFile, Format:=6, Delimiter:=",")
'Save it as Excel file, same name as text file
Wb.SaveAs Left(strFile, InStrRev(strFile, ".") - 1), xlWorkbookDefault
Wb.Close
Set Wb = Nothing
Set Wb = Workbooks.Open(strDir & "\informations.xlsx")
' boulot
Wb.Close

de faire cela:
Set Wb = Workbooks.Open(strFile, Format:=6, Delimiter:=",")
' boulot
'Save it as Excel file, same name as text file
Wb.SaveAs Left(strFile, InStrRev(strFile, ".") - 1), xlWorkbookDefault
Wb.Close
0
cletess Messages postés 38 Date d'inscription jeudi 10 janvier 2013 Statut Membre Dernière intervention 5 avril 2018
20 mars 2018 à 14:20
ça fonctionne tout à fait ! Je ne savais pas que je pouvais appliquer cette procédure sur un fichier .txt directement, je pensais devoir le convertir en .xlsx ! Du coup, ça simplifie pas mal le travail :)

Merci pour votre aide !
0
yg_be Messages postés 21095 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 février 2023 1 308 > cletess Messages postés 38 Date d'inscription jeudi 10 janvier 2013 Statut Membre Dernière intervention 5 avril 2018
20 mars 2018 à 15:09
pas utile non plus de faire le
Wb.SaveAs
, alors.
0
cletess Messages postés 38 Date d'inscription jeudi 10 janvier 2013 Statut Membre Dernière intervention 5 avril 2018
20 mars 2018 à 15:42
De fait, c'est accessoire :)

Merci !
0