Lister Dossiers et Fichiers d'un répertoire

**SlopFC** · 13/04/2014, 16h59

Bonjour,

Etant novice dans le domaine je me permet de me joindre à vous pour un service.
Actuellement via une macro, je peut lister tous les fichiers et sous-répertoires présent dans le répertoire ou se trouve le fichier excel.
Cependant, je souhaiterai Via une MsgBox pouvoir choisir le répertoire.

En vous remerciant d'avance.

Cordialement

--------------------------------------------------------------------------------------------------
Ci-dessous la macrro:
--------------------------------------------------------------------------------------------------

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Arborescence() 
 Application.ScreenUpdating = False 
 Racine = CurDir 
 If Racine = "" Then Exit Sub 
 Range("A:E").Clear 
 Range("A3").Select 
 Set fs = CreateObject("Scripting.FileSystemObject") 
 Set dossier_racine = fs.getfolder(Racine) 
 Lit_dossier dossier_racine, 1 
 Range("A1").Select 
End Sub 
Sub Lit_dossier(ByRef dossier, ByVal niveau) 
 With ActiveCell.Font 
 .Size = 11 
 .Underline = True 
 .Bold = True 
 ActiveCell.Value = decal(niveau - 1) & "--------> " & dossier.Name & " <-------- " 
ActiveCell.Interior.ColorIndex = 33 
 ActiveCell.Offset(1, 0).Select 
 For Each d In dossier.SubFolders 
 Lit_dossier d, niveau + 1 
 Next 
 For Each f In dossier.Files 
 nom_fich = f.Name 
 ActiveSheet.Hyperlinks.Add Anchor:=Selection, _ 
 Address:=dossier.Path & "\" & nom_fich, TextToDisplay:="" & nom_fich 
 ActiveCell.Offset(0, 1) = f.Size 
 ActiveCell.Offset(0, 2) = f.DateLastModified 
 ActiveCell.Offset(0, 3) = f.Attributes 
 If f.Attributes And vbHidden Then ActiveCell.Offset(0, 4) = "Caché" 
 ActiveCell.Interior.ColorIndex = 2 
 ActiveCell.Offset(1, 0).Select 
 Next 
End With 
End Sub 
Function decal(niv) 
 decal = String(3 * niv, " ") 
End Function 
Function ChoixDossier() 
 If Val(Application.Version) >= 10 Then 
 With Application.FileDialog(msoFileDialogFolderPicker) 
 .InitialFileName = ActiveWorkbook.Path & "\" 
 .Show 
 If .SelectedItems.Count > 0 Then 
 ChoixDossier = .SelectedItems(1) 
 Else 
 ChoixDossier = "" 
 End If 
 End With 
 Else 
 ChoixDossier = InputBox("Répertoire?") 
 End If 
End Function

**casefayere** · 13/04/2014, 17h26

Bonjour,
ci-dessous, un exemple dans lequel tu pourras puiser des infos

**kiki29** · 13/04/2014, 18h17

Bonjour, un de plus pour la route, via les API

**SlopFC** · 13/04/2014, 20h00

A ce stade, la fenêtre pour choisir le répertoire s'ouvre bien . Mais la macros persiste à relever les dossiers à l'endroit de l'enregistrement du fichier Excel et non au répertoire choisit .

**casefayere** · 13/04/2014, 20h50

je n'ai pas regardé ton fichier, quel exemple as-tu pris ? si c'est le mien, il ne devrait pas y avoir de problème, la seule chose c'est que les sous-répertoires sont pris en compte, modifies le code en fonction, je dis bien "si tu as pris mon exemple"

**SlopFC** · 13/04/2014, 21h37

Oui, j'ai bien utilisé ton exemple. Mais rien à faire, je n'arrive pas à récupérer autres choses que les dossiers à la source du fichier excel.

**casefayere** · 13/04/2014, 22h13

Pourtant, à partir de mon fichier, si j'enlève cette partie de code, dans la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
   If fld.SubFolders.Count > 0 Then
      For Each tFld In fld.SubFolders
         DoEvents
         FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
      Next
   End If

tu ne retrouves que les fichiers avec l'extension ou les extensions désirées dans le répertoire spécifié dans la MsgBox, j'ai, bien sur, controlé avant

**SlopFC** · 13/04/2014, 22h42

Oui en effet à partir de ton fichier, cela fonctionne bien. Mais j'essaye de l'adapter à mon fichier qui me permet d'avoir plus de renseignements sur les fichiers (Date modification, taille et Hyperlien). Et qui permet également de pas se limiter à une extension.

Encore merci de votre aide et votre patience pour un novice comme moi .

Cordialement

**casefayere** · 14/04/2014, 08h15

Bonjour,
autre exemple, qui peut créer les liens hypertext, l'extension est choisie dans le TextBox => "OK" =>le répertoire dans la boite de dialogue.

**SlopFC** · 14/04/2014, 11h26

Bonjour,

Encore merci de ta réponse.
Si je prend ton fichier, a quel endroit je doit rajouter cette partie de code (Ci-dessous), pour pouvoir conserver la mise en forme, l'affichage de la taille ainsi que la date de modification ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   With ActiveCell.Font
        .Size = 11
        .Underline = True
        .Bold = True
   ActiveCell.Value = decal(niveau - 1) & "--------> " & dossier.Name & " <-------- "
   ActiveCell.Interior.ColorIndex = 33
   ActiveCell.Offset(1, 0).Select
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
   For Each f In dossier.Files
     nom_fich = f.Name
     ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
     Address:=dossier.Path & "\" & nom_fich, TextToDisplay:="" & nom_fich
     ActiveCell.Offset(0, 1) = f.Size
     ActiveCell.Offset(0, 2) = f.DateLastModified
     ActiveCell.Offset(0, 3) = f.Attributes
     If f.Attributes And vbHidden Then ActiveCell.Offset(0, 4) = "Caché"
     ActiveCell.Interior.ColorIndex = 2
     ActiveCell.Offset(1, 0).Select
   Next
End With
End Sub
Function decal(niv)
   decal = String(3 * niv, " ")
End Function

**casefayere** · 14/04/2014, 15h13

Je ne t'oublie pas mais je suis très occupé (métier oblige), patientes, je regarderai de plus près

**grisan29** · 14/04/2014, 20h23

bonsoir slopFC, casefayere et le forum

si tu rajouter un

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

call Lit_dossier

dans le code ou tu veux que cela apparaisse, je ne sais si cela va fonctionner mais!!!!

Pascal

**SlopFC** · 14/04/2014, 23h22

Bonsoir,

Ca avance petit à petit... A présent , j'arrive bien à récupérer les fichiers d'un répertoire choisit. Cependant à l'ouverture de la fenêtre, si je choisit bien un répertoire, tout se passe sans erreur. Si j'annule sans choisir de répertoire une erreur apparait: " Erreur d'exécution 5 , Argument ou appel de procédure incorrect"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Arborescence()
 Application.ScreenUpdating = False
Dim fd As FileDialog
  Dim Racine As String
       Racine = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Racine & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
          MsgBox "Vous avez sélectionné le répertoire : " & .SelectedItems(1), vbInformation
        If .SelectedItems.Count > 0 Then
        Chemin = .SelectedItems(1)
        End If
 
        End With
 
 If Racine = "" Then Exit Sub
 Range("A:E").Clear
 Range("A3").Select
 Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Chemin)
Lit_dossier dossier_racine, 1
  Range("A1").Select
 
End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   With ActiveCell.Font
        .Size = 11
        .Underline = True
        .Bold = True
   ActiveCell.Value = decal(niveau - 1) & "--------> " & dossier.Name & " <-------- "
   ActiveCell.Interior.ColorIndex = 33
   ActiveCell.Offset(1, 0).Select
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
   For Each f In dossier.Files
     nom_fich = f.Name
     ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
     Address:=dossier.Path & "\" & nom_fich, TextToDisplay:="" & nom_fich
     ActiveCell.Offset(0, 1) = f.Size
     ActiveCell.Offset(0, 2) = f.DateLastModified
     ActiveCell.Offset(0, 3) = f.Attributes
     If f.Attributes And vbHidden Then ActiveCell.Offset(0, 4) = "Caché"
     ActiveCell.Interior.ColorIndex = 2
     ActiveCell.Offset(1, 0).Select
   Next
End With
End Sub
Function decal(niv)
   decal = String(3 * niv, " ")
End Function

**SlopFC** · 14/04/2014, 23h25

Envoyé par casefayere

Je ne t'oublie pas mais je suis très occupé (métier oblige), patientes, je regarderai de plus près

Pas de problème, je comprend

Merci à toi et à ceux qui prennent du temps pour me répondre.

**casefayere** · 15/04/2014, 08h18

Bonjour grisan29, SlopFC, le forum,

A SlopFC :
j'ai refait ce fichier (en reprenant certains de tes bouts de code) à ma façon sans savoir si ça peut correspondre à tes besoins, il faudra certainement une adaptation.

Bonne journée

PS : il sera certainement utile d'épurer toutes les variables qui semblent inutiles, exemple bidon

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub toto()
Dim x As Long, y As Long
For x = 1 To 50
  Range("A" & x) = "toto" & x
Next x
For y = 3 To 200
  Range("B" & y) = "titi" & y
Next y
End Sub

en nettoyant y, ça devient

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub toto()
Dim x As Long
For x = 1 To 50
  Range("A" & x) = "toto" & x
Next x
For x = 3 To 200
  Range("B" & x) = "titi" & x
Next x
End Sub

**SlopFC** · 16/04/2014, 22h58

Bonsoir,

Merci à vous, j'ai enfin eu ce dont je voulais. Une dernière petit chose.... actuellement mes fichiers sont triés par ordre croissant dans le tableau excel. Est'il possible de les classer par date de modification ? ???

Ci-joint le fichier .

Cordialement

**casefayere** · 24/04/2014, 15h11

Bonjour,
et simplement en ajoutant un tri, ça n'irait pas ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
With ActiveSheet
  Set x = .Range("a" & .Rows.Count).End(xlUp)
  .Range("A4", x(1, 5)).Sort key1:=.Range("C4"), order1:=xlAscending, Header:=xlNo
End With

à toi de bien le placer

Lister Dossiers et Fichiers d'un répertoire

Macros et VBA Excel

Discussions similaires

Partager

Partager