Sujet Précédent Sujet Suivant

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

Fermé
jannot1986
Messages postés
9
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
25 septembre 2019
 - Modifié le 30 avril 2019 à 05:17
michel_m
Messages postés
16574
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
3 août 2022
 - 30 avril 2019 à 10:16
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.
A voir également:

2 réponses

Réponse 1 / 2
cs_Le Pivert
Messages postés
7801
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
9 août 2022
 714
30 avril 2019 à 08:09
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/

0
Réponse 2 / 2
michel_m
Messages postés
16574
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
3 août 2022
 3 277
Modifié le 30 avril 2019 à 10:24
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

0