Menu

Macro Excel Ouvrir les dossiers ds un repertoire et acceder au fichier y contenu

Messages postés
6
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
30 avril 2019
-
Bonjour à tous,
j'ai dans un repertoire 8 dossiers.
Chaque dossier contient des fichiers excel.
Je voudrais créer une boucle qui devrait .
- ouvrir le premier dossier, puis ouvrir, copier et compiler dans un nouveau classeur excel les données de chaque fichier excel contenu ds ce premier dossier
- passer au second dossier et executer les memes actions et ainsi de suite.

Pour l'instant je suis capable de creer une boucle qui copie et compile uniquement des fichiers excel contenues dans un seul dossier. Je voudrais à cet effet un code qui me permette d'executer les memes actions sur les autres dossiers contenues dans ce repertoire.

Voila le code qui me permet de compiler les données du dossier1
Option Explicit
'Déclaration des Variables
Dim Chemin As String, Fichier As String
Dim LigneTotal As Long
Dim Derligne As Long


Sub macro_compil()
'

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("compils").Visible = True
Worksheets("compils").Select
Rows("1:1000000").Select
Selection.Clear
Range("A1").Select
Range("A1").Value = "Department"
Range("B1").Value = "Date_"
Range("C1").Value = "Numéro_"
Range("D1").Value = "Code_"
Range("E1").Value = "Nom_"
Range("F1").Value = "Classe"
Range("G1").Value = "Montant"
Range("H1").Value = "Type_Paiement"
Range("I1").Value = "Region"
Range("J1").Value = "Department"
Range("K1").Value = "Arrondissement"
Range("L1").Value = "NOM ETABLISSEMENT"
Range("M1").Value = "Type"
Range("N1").Value = "Motif"


ChDir "C:\Users\JANNOT\Desktop\DONNEES ADAMAOUA\Dossier1"
Chemin = Dir("C:\Users\JANNOT\Desktop\DONNEES ADAMAOUA\Dossier1\*.xls")


While Len(Chemin) > 0
Workbooks.Open "C:\Users\JANNOT\Desktop\DONNEES ADAMAOUA\Dossier1\" & Chemin
LigneTotal = ActiveSheet.UsedRange.Rows.Count
Range("A2:N" & LigneTotal).Copy
Workbooks("Macro_compil_minesec.xlsm").Activate
Derligne = Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row + 1
Range("A" & Derligne).Select
ActiveSheet.Paste
Workbooks(Chemin).Close
Chemin = Dir
Wend

Worksheets("Compils").Activate
Worksheets("Compils").Select
Range("A1:N1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\JANNOT\Desktop\DONNEES ADAMAOUA\Compils donnees ADAMAOUA.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Worksheets("Compils").Select
Rows("1:1000000").Select
Selection.ClearContents
Range("A1").Select
Worksheets("Compils").Visible = False

End Sub

Merci d'avance.
Afficher la suite 

2 réponses

Messages postés
6106
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
18 juin 2019
370
0
Merci
Bonjour,

voir ceci pour parcourir un dossier ainsi que ses sous-dossiers:

https://grenier.self-access.com/access/fichiers/lister-les-fichiers-dun-dossier-ses-dossiers/

Commenter la réponse de cs_Le Pivert
Messages postés
15870
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
18 juin 2019
2747
0
Merci
Bonjour

'ton code ne comporte pas de commentaires et il est ainsi ardu de s'y retrouver pour comprendre et aider
pour lister tes sous dossiers
tu as intér^t à créer une sous macro pour chaque sous dossier

Option Explicit
'-------------------------------------------------------------------
'd'après code de Fred Sigonneau
Sub TousLesDossiers(LeDossier)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object, Liste As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)

'examen du dossier courant
For Each Flder In Dossier.subfolders
chemin = Flder.Path
'lancer une sous macro qui reprend l'examen de chaque sous dossier
Call transferer(chemin)
Next

Set fso = Nothing

End Sub

'-------------------------------------------------------------------------
Sub test()
TousLesDossiers "C:\Users\JANNOT\Desktop\DONNEES ADAMAOUA"
End Sub

</code>

D'autre part dans ce genre de cas, il existe une technique qui évite d'ouvrir les fichiers pour la rapidité et le confort visuel avec la technologie ADO
mais guère de temps aujourd'hui pour t'aider et pour comprendre ton code

Commenter la réponse de michel_m