Comment lister sur une feuille tous les fichiers, leur taille, et le répertoire dans lmesquels ils sont situés ?
Copie ce qui suit dans un module standard d'un fichier vierge
A ) Dans le haut du module, tu dois déclarer la variable A
B ) Dans la procédure "Test" indique le répertoire à tester
Dim A As Long
'----------------------------------
Sub test()
Dim Nb&, taille As Double
'nombre de fichiers et la taille de chacun d'eux
'dans le répertoire spécifié et ses
'sous-répertoires
Application.ScreenUpdating = False
A = 1
'Répertoire à adapter
NbDeFichiers "c:Atravail", Nb&, taille, True
With Worksheets("Feuil1")
.Range("A1") = "Nom du répertoire"
.Range("B1") = "Nom du fichier"
.Range("C1") = "Taille du fichier"
.Range("C" & A + 1) = taille
.Range("B" & A + 1) = "Total (en octets)"
.Range("B" & A + 1).Font.Bold = True
.Range("C" & A + 1).Font.Bold = True
.Range("A1:C1").Font.Bold = True
.Range("A:C").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "Nombre de fichiers : " & Nb & " " & vbCrLf & _
"taille du répertoire : " & taille & " octets."
End Sub
'----------------------------------
Sub NbDeFichiers(LeDossier$, Cpte&, taille As Double, _
Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
For Each file In Dossier.Files
Cpte = Cpte + 1
taille = taille + file.Size
A = A + 1
With Worksheets("Feuil1")
.Cells(A, "A") = Dossier.Name
.Cells(A, "B") = file.Name
.Cells(A, "C") = file.Size
End With
Next
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeFichiers sousRep.Path, Cpte, taille
Next sousRep
End If
Set fso = Nothing
End Sub
'----------------------------------
Il se peut que tu trouves dana la liste plusieurs fichiers ayant ce nom : Thumbs.db
Tu trouveras l'explication à cette adresse :
http://www.siteduzero.com/tuto-3-17335-1-supprimer-les-thumbs-db.html
A ) Dans le haut du module, tu dois déclarer la variable A
B ) Dans la procédure "Test" indique le répertoire à tester
Dim A As Long
'----------------------------------
Sub test()
Dim Nb&, taille As Double
'nombre de fichiers et la taille de chacun d'eux
'dans le répertoire spécifié et ses
'sous-répertoires
Application.ScreenUpdating = False
A = 1
'Répertoire à adapter
NbDeFichiers "c:Atravail", Nb&, taille, True
With Worksheets("Feuil1")
.Range("A1") = "Nom du répertoire"
.Range("B1") = "Nom du fichier"
.Range("C1") = "Taille du fichier"
.Range("C" & A + 1) = taille
.Range("B" & A + 1) = "Total (en octets)"
.Range("B" & A + 1).Font.Bold = True
.Range("C" & A + 1).Font.Bold = True
.Range("A1:C1").Font.Bold = True
.Range("A:C").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "Nombre de fichiers : " & Nb & " " & vbCrLf & _
"taille du répertoire : " & taille & " octets."
End Sub
'----------------------------------
Sub NbDeFichiers(LeDossier$, Cpte&, taille As Double, _
Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
For Each file In Dossier.Files
Cpte = Cpte + 1
taille = taille + file.Size
A = A + 1
With Worksheets("Feuil1")
.Cells(A, "A") = Dossier.Name
.Cells(A, "B") = file.Name
.Cells(A, "C") = file.Size
End With
Next
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeFichiers sousRep.Path, Cpte, taille
Next sousRep
End If
Set fso = Nothing
End Sub
'----------------------------------
Il se peut que tu trouves dana la liste plusieurs fichiers ayant ce nom : Thumbs.db
Tu trouveras l'explication à cette adresse :
http://www.siteduzero.com/tuto-3-17335-1-supprimer-les-thumbs-db.html
Denis Michon,
Ajouté ou modifié le 05/01/2008 (N°1952)
Ajouté ou modifié le 05/01/2008 (N°1952)
Comment récupérer avec VBA le nombre de sous-dossiers et de fichiers contenus dans un dossier ?
Sub test()
Dim Nb&
'nombre de fichiers dans le répertoire spécifié
NbDeFichiers "c:Atravail", Nb&, False
MsgBox Nb: Nb = 0
'nombre total de fichiers dans le répertoire
'indiqué et tous sous-répertoires
NbDeFichiers "c:Atravail", Nb&
MsgBox Nb: Nb = 0
'nombre de répertoires dans le répertoire indiqué
NbDeDossiers "c:Atravail", Nb&, False
MsgBox Nb: Nb = 0
'nombre total de répertoires dans le répertoire
'indiqué et dans tous ses répertoires.
NbDeDossiers "c:Atravail", Nb&
MsgBox Nb
End Sub
'-----------------------------------------
Sub NbDeFichiers(LeDossier$, Cpte&, Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
Cpte = Cpte + Dossier.Files.Count
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeFichiers sousRep.Path, Cpte
Next sousRep
End If
Set fso = Nothing
End Sub 'fs
'-----------------------------------------
Sub NbDeDossiers(DossierRacine$, Cpte&, Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(DossierRacine)
Cpte = Cpte + Dossier.SubFolders.Count
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeDossiers sousRep.Path, Cpte
Next sousRep
End If
Set fso = Nothing
End Sub
'-----------------------------------------
Dim Nb&
'nombre de fichiers dans le répertoire spécifié
NbDeFichiers "c:Atravail", Nb&, False
MsgBox Nb: Nb = 0
'nombre total de fichiers dans le répertoire
'indiqué et tous sous-répertoires
NbDeFichiers "c:Atravail", Nb&
MsgBox Nb: Nb = 0
'nombre de répertoires dans le répertoire indiqué
NbDeDossiers "c:Atravail", Nb&, False
MsgBox Nb: Nb = 0
'nombre total de répertoires dans le répertoire
'indiqué et dans tous ses répertoires.
NbDeDossiers "c:Atravail", Nb&
MsgBox Nb
End Sub
'-----------------------------------------
Sub NbDeFichiers(LeDossier$, Cpte&, Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
Cpte = Cpte + Dossier.Files.Count
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeFichiers sousRep.Path, Cpte
Next sousRep
End If
Set fso = Nothing
End Sub 'fs
'-----------------------------------------
Sub NbDeDossiers(DossierRacine$, Cpte&, Optional SousDossiers As Boolean = True)
Dim fso As Object, Dossier As Object
Dim sousRep As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(DossierRacine)
Cpte = Cpte + Dossier.SubFolders.Count
'traitement récursif des sous dossiers
If SousDossiers Then
For Each sousRep In Dossier.SubFolders
NbDeDossiers sousRep.Path, Cpte
Next sousRep
End If
Set fso = Nothing
End Sub
'-----------------------------------------
Frédéric Sigonneau,
Ajouté ou modifié le 21/12/2007 (N°1951)
Ajouté ou modifié le 21/12/2007 (N°1951)
Comment sélectionner plusieurs fichiers dans un répertoire sélectionné avec l'explorateur et les ouvrir ?
Utilise cette macro :
Sub multiselection()
' Affichage de la boîte de dialogue standard "Ouvrir" pour sélection de(s) fichier (s)
nomfich = Application.GetOpenFilename(Title:="Ouverture des fichiers CEXP", MultiSelect:=True)
' si aucun choix effectué, sortie du programme
If TypeName(nomfich) = "Boolean" Then
'MsgBox("Aucun fichier n'a été sélectionné. Fin de la procédure", vbCritical + vbOKOnly,"Sortie")
Exit Sub
End If
' si choix
If UBound(nomfich) > 1 Then
Dim rep As Long
Dim Liste As String
Dim compteur As Byte
For compteur = 1 To UBound(nomfich)
Liste = Liste & vbCr & nomfich(compteur)
Next compteur
'affichage de l'ensemble de la liste des fichiers et proposition d 'ouverture
rep = MsgBox("Voici la liste des fichiers CEXP sélectionnés." _
& Liste & vbCr & "Voulez-vous les ouvrir ?", vbYesNo + vbQuestion, "Ouvrir les fichiers CEXP ?")
'ouverture des fichiers en cas de réponse positive
If rep = vbYes Then
For compteur = 1 To UBound(nomfich)
Workbooks.Open Filename:=nomfich(compteur)
Next compteur
End If
Else
Workbooks.Open Filename:=nomfich(1) 'si un seul fichier a été sélectionné, il est ouvert
End If
End Sub
Sub multiselection()
' Affichage de la boîte de dialogue standard "Ouvrir" pour sélection de(s) fichier (s)
nomfich = Application.GetOpenFilename(Title:="Ouverture des fichiers CEXP", MultiSelect:=True)
' si aucun choix effectué, sortie du programme
If TypeName(nomfich) = "Boolean" Then
'MsgBox("Aucun fichier n'a été sélectionné. Fin de la procédure", vbCritical + vbOKOnly,"Sortie")
Exit Sub
End If
' si choix
If UBound(nomfich) > 1 Then
Dim rep As Long
Dim Liste As String
Dim compteur As Byte
For compteur = 1 To UBound(nomfich)
Liste = Liste & vbCr & nomfich(compteur)
Next compteur
'affichage de l'ensemble de la liste des fichiers et proposition d 'ouverture
rep = MsgBox("Voici la liste des fichiers CEXP sélectionnés." _
& Liste & vbCr & "Voulez-vous les ouvrir ?", vbYesNo + vbQuestion, "Ouvrir les fichiers CEXP ?")
'ouverture des fichiers en cas de réponse positive
If rep = vbYes Then
For compteur = 1 To UBound(nomfich)
Workbooks.Open Filename:=nomfich(compteur)
Next compteur
End If
Else
Workbooks.Open Filename:=nomfich(1) 'si un seul fichier a été sélectionné, il est ouvert
End If
End Sub
non précisé,
Ajouté ou modifié le 25/11/2007 (N°1931)
Ajouté ou modifié le 25/11/2007 (N°1931)
Comment récupérer la valeur écrite en feuil1!A1 dans un groupe de classeurs contenus dans un même répertoire et la copier dans une colonne d'un autre classeur ?
Utilise cette macro :
Sub boucle()
Dim Dossier As String, Ctr As Long, Fichier As String
Dossier = "C:\Atravail"
Ctr = 1
Fichier = Dir(Dossier & "*.xls")
Do While Fichier <> ""
Workbooks.Open Dossier & Fichier
ThisWorkbook.Sheets("Feuil1").Cells(Ctr, 1) = [A1]
Ctr = Ctr + 1
Fichier = Dir
Loop
End Sub
Quelques commentaires sur la gestion de répertoires avec excel :
Si au lieu d'écrire
Workbooks.open Dossier & Fichier tu ne mets que Workbooks.Open Fichier, en abscence d'indication du répertoire à utiliser, excel cherche dans le répertoire courant. Ce répertoire est celui que tu as défini ou inscrit dans Barre des menus / outils / options / onglet Général / "Dossier par défaut". Si ce n'est pas dans ce dossier que tu as mis les fichiers dans lesquels tu veux collecter l'info, excel te renverrra une erreur.
Tu peux définir le dossier par programmation en utilisant :
Chdir "MonNouveauRépertoireParDéfaut" soit "c:\Atravail"
Si ce répertoire est sur un autre lecteur:
Dossier = "D:\Atravail"
il faut ajouter l'instruction
ChDrive "D"
Chdir Dossier
On peut alors utiliser la version courte pour ouvrir les fichiers : que Workbooks.Open Fichier
Sub boucle()
Dim Dossier As String, Ctr As Long, Fichier As String
Dossier = "C:\Atravail"
Ctr = 1
Fichier = Dir(Dossier & "*.xls")
Do While Fichier <> ""
Workbooks.Open Dossier & Fichier
ThisWorkbook.Sheets("Feuil1").Cells(Ctr, 1) = [A1]
Ctr = Ctr + 1
Fichier = Dir
Loop
End Sub
Quelques commentaires sur la gestion de répertoires avec excel :
Si au lieu d'écrire
Workbooks.open Dossier & Fichier tu ne mets que Workbooks.Open Fichier, en abscence d'indication du répertoire à utiliser, excel cherche dans le répertoire courant. Ce répertoire est celui que tu as défini ou inscrit dans Barre des menus / outils / options / onglet Général / "Dossier par défaut". Si ce n'est pas dans ce dossier que tu as mis les fichiers dans lesquels tu veux collecter l'info, excel te renverrra une erreur.
Tu peux définir le dossier par programmation en utilisant :
Chdir "MonNouveauRépertoireParDéfaut" soit "c:\Atravail"
Si ce répertoire est sur un autre lecteur:
Dossier = "D:\Atravail"
il faut ajouter l'instruction
ChDrive "D"
Chdir Dossier
On peut alors utiliser la version courte pour ouvrir les fichiers : que Workbooks.Open Fichier
Denis Michon,
Ajouté ou modifié le 28/10/2007 (N°1910)
Ajouté ou modifié le 28/10/2007 (N°1910)
Comment récupérer la valeur écrite en feuil1!A1 dans un groupe de classeurs contenus dans un même répertoire et la copier dans une colonne d'un autre classeur ?
Utilise cette macro :
Sub boucle()
Dim Dossier As String, Ctr As Long, Fichier As String
Dossier = "C:\Atravail"
Ctr = 1
Fichier = Dir(Dossier & "*.xls")
Do While Fichier <> ""
Workbooks.Open Dossier & Fichier
ThisWorkbook.Sheets("Feuil1").Cells(Ctr, 1) = [A1]
Ctr = Ctr + 1
Fichier = Dir
Loop
End Sub
Quelques commentaires sur la gestion de répertoires avec excel :
Si au lieu d'écrire
Workbooks.open Dossier & Fichier tu ne mets que Workbooks.Open Fichier, en abscence d'indication du répertoire à utiliser, excel cherche dans le répertoire courant. Ce répertoire est celui que tu as défini ou inscrit dans Barre des menus / outils / options / onglet Général / "Dossier par défaut". Si ce n'est pas dans ce dossier que tu as mis les fichiers dans lesquels tu veux collecter l'info, excel te renverrra une erreur.
Tu peux définir le dossier par programmation en utilisant :
Chdir "MonNouveauRépertoireParDéfaut" soit "c:\Atravail"
Si ce répertoire est sur un autre lecteur:
Dossier = "D:\Atravail"
il faut ajouter l'instruction
ChDrive "D"
Chdir Dossier
On peut alors utiliser la version courte pour ouvrir les fichiers : que Workbooks.Open Fichier
Sub boucle()
Dim Dossier As String, Ctr As Long, Fichier As String
Dossier = "C:\Atravail"
Ctr = 1
Fichier = Dir(Dossier & "*.xls")
Do While Fichier <> ""
Workbooks.Open Dossier & Fichier
ThisWorkbook.Sheets("Feuil1").Cells(Ctr, 1) = [A1]
Ctr = Ctr + 1
Fichier = Dir
Loop
End Sub
Quelques commentaires sur la gestion de répertoires avec excel :
Si au lieu d'écrire
Workbooks.open Dossier & Fichier tu ne mets que Workbooks.Open Fichier, en abscence d'indication du répertoire à utiliser, excel cherche dans le répertoire courant. Ce répertoire est celui que tu as défini ou inscrit dans Barre des menus / outils / options / onglet Général / "Dossier par défaut". Si ce n'est pas dans ce dossier que tu as mis les fichiers dans lesquels tu veux collecter l'info, excel te renverrra une erreur.
Tu peux définir le dossier par programmation en utilisant :
Chdir "MonNouveauRépertoireParDéfaut" soit "c:\Atravail"
Si ce répertoire est sur un autre lecteur:
Dossier = "D:\Atravail"
il faut ajouter l'instruction
ChDrive "D"
Chdir Dossier
On peut alors utiliser la version courte pour ouvrir les fichiers : que Workbooks.Open Fichier
Denis Michon,
Ajouté ou modifié le 28/10/2007 (N°1910)
Ajouté ou modifié le 28/10/2007 (N°1910)
Comme établir la liste des fichiers contenus dans un répertoire avec un lien hypertexte pointant sur chacun ?
La macro Repertorier appelle la fonction Lister en lui passant en paramètres les choix de l'utilisateur sur
- le dossier à analyser
- L'inclusion ou non des sous dossiers,
- Le N° de la ligne ou commencer à incrire les données
- Le filtrage éventuel sur un type de fichier.
Sub Repertorier()
'Une méthode basique sans API pour lister les répertoires et
'sous-répertoires. Michel Pierron, MPFE 2002. Adaptation Flo Cabon sur une idée de "mrik"
'* nRow = Ligne de départ
'* FolderName = Chemin du répertoire à lister
'* Suffix = Filtre optionnel des types de fichiers
'* SubDir = True pour étendre la liste aux sous-répertoires
Dim LeMessage As String, LeRepertoire As String, Lextension As String
Dim Profondeur As VbMsgBoxResult
Dim nRow As Long
LeMessage = "Choisissez le dossier à analyser"
LeRepertoire = GetDirectory(LeMessage)
Lextension = InputBox("indiquez éventuellement une extension de fichier pour filtrer les fichiers", "Type de fichier", "*.*")
Profondeur = MsgBox("Voulez vous analyser aussi les sous-répertoires ?", vbYesNo, "Profondeur d'analyse")
nRow = InputBox("indiquez le N° de la première ligne pour le tableau de sortie", "Sortie des résultats", "1")
If Profondeur = vbYes Then
truc = Lister(nRow, LeRepertoire, Lextension, True)
Else
truc = Lister(nRow, LeRepertoire, Lextension, False)
End If
End Sub
Function Lister(nRow&, FolderName$, Optional Suffix$ = "*.*", Optional SubDir As Boolean = True)
Dim i As Long, x As Long, File As String, Folder As String, nbFolders() As String
Cells(nRow, 1) = FolderName
Cells(nRow, 1).Font.Bold = True
If Not Right(FolderName, 1) = "\" Then FolderName = FolderName & "\"
File = Dir(FolderName & Suffix)
Do While Len(File) > 0
With ActiveSheet
.Hyperlinks.Add Anchor:=.Cells(nRow, 2), _
Address:=FolderName & File, _
TextToDisplay:=File
End With
nRow = nRow + 1
File = Dir
Loop
If Not SubDir Then Exit Function
x = 0
Folder = Dir(FolderName, vbDirectory)
Do While Folder > ""
If Folder <> "." And Folder <> ".." Then
If (GetAttr(FolderName & Folder) And vbDirectory) = vbDirectory Then x = x + 1
End If
Folder = Dir
Loop
ReDim nbFolders(x + 1)
i = 1
nbFolders(i) = Dir(FolderName, vbDirectory)
Do While nbFolders(i) > ""
If nbFolders(i) <> "." And nbFolders(i) <> ".." Then
If (GetAttr(FolderName & nbFolders(i)) And vbDirectory) = vbDirectory Then i = i + 1
End If
nbFolders(i) = Dir
Loop
For i = 1 To UBound(nbFolders()) - 1
Call Lister(nRow, FolderName & nbFolders(i), Suffix)
Next
End Function
Dans le fichier associé, se trouve également un exemple d'utilisation de la fonction getdirectory qui permet de choisir un dossier à la souris.
- le dossier à analyser
- L'inclusion ou non des sous dossiers,
- Le N° de la ligne ou commencer à incrire les données
- Le filtrage éventuel sur un type de fichier.
Sub Repertorier()
'Une méthode basique sans API pour lister les répertoires et
'sous-répertoires. Michel Pierron, MPFE 2002. Adaptation Flo Cabon sur une idée de "mrik"
'* nRow = Ligne de départ
'* FolderName = Chemin du répertoire à lister
'* Suffix = Filtre optionnel des types de fichiers
'* SubDir = True pour étendre la liste aux sous-répertoires
Dim LeMessage As String, LeRepertoire As String, Lextension As String
Dim Profondeur As VbMsgBoxResult
Dim nRow As Long
LeMessage = "Choisissez le dossier à analyser"
LeRepertoire = GetDirectory(LeMessage)
Lextension = InputBox("indiquez éventuellement une extension de fichier pour filtrer les fichiers", "Type de fichier", "*.*")
Profondeur = MsgBox("Voulez vous analyser aussi les sous-répertoires ?", vbYesNo, "Profondeur d'analyse")
nRow = InputBox("indiquez le N° de la première ligne pour le tableau de sortie", "Sortie des résultats", "1")
If Profondeur = vbYes Then
truc = Lister(nRow, LeRepertoire, Lextension, True)
Else
truc = Lister(nRow, LeRepertoire, Lextension, False)
End If
End Sub
Function Lister(nRow&, FolderName$, Optional Suffix$ = "*.*", Optional SubDir As Boolean = True)
Dim i As Long, x As Long, File As String, Folder As String, nbFolders() As String
Cells(nRow, 1) = FolderName
Cells(nRow, 1).Font.Bold = True
If Not Right(FolderName, 1) = "\" Then FolderName = FolderName & "\"
File = Dir(FolderName & Suffix)
Do While Len(File) > 0
With ActiveSheet
.Hyperlinks.Add Anchor:=.Cells(nRow, 2), _
Address:=FolderName & File, _
TextToDisplay:=File
End With
nRow = nRow + 1
File = Dir
Loop
If Not SubDir Then Exit Function
x = 0
Folder = Dir(FolderName, vbDirectory)
Do While Folder > ""
If Folder <> "." And Folder <> ".." Then
If (GetAttr(FolderName & Folder) And vbDirectory) = vbDirectory Then x = x + 1
End If
Folder = Dir
Loop
ReDim nbFolders(x + 1)
i = 1
nbFolders(i) = Dir(FolderName, vbDirectory)
Do While nbFolders(i) > ""
If nbFolders(i) <> "." And nbFolders(i) <> ".." Then
If (GetAttr(FolderName & nbFolders(i)) And vbDirectory) = vbDirectory Then i = i + 1
End If
nbFolders(i) = Dir
Loop
For i = 1 To UBound(nbFolders()) - 1
Call Lister(nRow, FolderName & nbFolders(i), Suffix)
Next
End Function
Dans le fichier associé, se trouve également un exemple d'utilisation de la fonction getdirectory qui permet de choisir un dossier à la souris.
Michel Pierron, Flo Cabon,
Ajouté ou modifié le 18/09/2005 (N°1671)
Ajouté ou modifié le 18/09/2005 (N°1671)
Comment récupérer la liste des fichiers d'un répertoire et l'afficher triée par ordre
alphabétique
dans une listbox sur un userform ?
Initialise ta liste avec la macro ci dessous :
Private Sub UserForm_Initialize()
Dim Fs As FileSearch
Dim Dossier As String
Dim I As Integer
On Error Resume Next
Set Fs = Application.FileSearch
Dossier = "D:\MonDossier\"
With Fs
.NewSearch
.Filename = "*.xls"
.LookIn = Dossier
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
Me.ListBox1.AddItem Dir(.Item(I))
Next I
End With
Else
MsgBox "Aucun classeur trouvés " & _
"dans le dossier '" & Dossier & "'."
Me.ListBox1.AddItem "Aucun classeur !"
End If
End With
Set Fs = Nothing
End Sub
Private Sub UserForm_Initialize()
Dim Fs As FileSearch
Dim Dossier As String
Dim I As Integer
On Error Resume Next
Set Fs = Application.FileSearch
Dossier = "D:\MonDossier\"
With Fs
.NewSearch
.Filename = "*.xls"
.LookIn = Dossier
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
Me.ListBox1.AddItem Dir(.Item(I))
Next I
End With
Else
MsgBox "Aucun classeur trouvés " & _
"dans le dossier '" & Dossier & "'."
Me.ListBox1.AddItem "Aucun classeur !"
End If
End With
Set Fs = Nothing
End Sub
Hervé,
Ajouté ou modifié le 30/05/2004 (N°1433)
Ajouté ou modifié le 30/05/2004 (N°1433)
Sous VBA, existe-t-il un contrôle permettant de simuler l'explorateur Windows pour
pourvoir naviguer sur les disques pour choisir un dossier et non pas un fichier ?
Tu peux le faire sans Control activex externe avec la méthode suivante (fait avec officeXP)
Sub test()
Dim Dlg As FileDialog
Dim i As Integer
Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
Dlg.Show
MsgBox Dlg.SelectedItems(1)
End sub
Sub test()
Dim Dlg As FileDialog
Dim i As Integer
Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
Dlg.Show
MsgBox Dlg.SelectedItems(1)
End sub
Esteban,
Ajouté ou modifié le 15/05/2004 (N°1391)
Ajouté ou modifié le 15/05/2004 (N°1391)
Sous VBA, existe-t-il un contrôle permettant de simuler l'explorateur Windows ? Je souhaite
pourvoir naviguer sur les disques pour choisir un dossier et non pas un fichier .....
Tu peux le faire sans Control activex externe avec la méthode suivante (fait avec officeXP)
Sub test()
Dim Dlg As FileDialog
Dim i As Integer
Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
Dlg.Show
MsgBox Dlg.SelectedItems(1)
End sub
Sub test()
Dim Dlg As FileDialog
Dim i As Integer
Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
Dlg.Show
MsgBox Dlg.SelectedItems(1)
End sub
Esteban,
Ajouté ou modifié le 25/10/2003 (N°1259)
Ajouté ou modifié le 25/10/2003 (N°1259)
Je voudrais créer un répertoire des différent dossiers, sous dossiers, fichiers de mon
ordinateur avec des liens hypertextes pointant sur les fichiers.
Sub remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de la
' cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de gauche
' il reste a écrire la section date et heure 14/02/2000 18:30
Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String
ExtLocale = ExtFichier
LeFichier = Dir(RepertParent & ExtFichier)
If Len(LeFichier) = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If
Do While Len(LeFichier) <> 0
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = LeFichier
ActiveCell.Offset(1, -1).Select
LeFichier = Dir
Loop
'Compter le nombre de sous-répertoires
NbreRepert = 0
LeDossier = Dir(RepertParent, vbDirectory)
Do While LeDossier <> ""
If LeDossier <> "." And LeDossier <> ".." Then
If (GetAttr(RepertParent & LeDossier) And vbDirectory) = vbDirectory Then
NbreRepert = NbreRepert + 1
End If
End If
LeDossier = Dir
Loop
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
Do While LeDossierLocal(Compteur) <> ""
If LeDossierLocal(Compteur) <> "." And LeDossierLocal(Compteur) <> ".." Then
If (GetAttr(RepertParent & LeDossierLocal(Compteur)) And vbDirectory) = vbDirectory Then
Compteur = Compteur + 1
End If
End If
LeDossierLocal(Compteur) = Dir
Loop
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & "\"
Call remplir(ParentLocal, ExtLocale)
Next
End Sub
Sub mondir()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim LeMessage As String
Dim Arret As Boolean
LeTitre = "Répertoires et sous-répertoires"
LeMessage = "Taper le nom complet du répertoire"
Arret = False
Do
LeChemin = InputBox(LeMessage, LeTitre, LeChemin)
If Len(LeChemin) = 0 Then
Arret = True
Else
If Mid(LeChemin, Len(LeChemin), 1) <> "\" Then
LeChemin = LeChemin + "\"
End If
If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
Lextension = InputBox("Taper le type de fichier à afficher",
LeTitre, "*.*")
Call remplir(LeChemin, Lextension)
Arret = True
Else
LeMessage = "Répertoire introuvable...Recommencer ?"
End If
End If
Loop Until Arret
End Sub
Auteur inconnu. Transmis par
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de la
' cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de gauche
' il reste a écrire la section date et heure 14/02/2000 18:30
Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String
ExtLocale = ExtFichier
LeFichier = Dir(RepertParent & ExtFichier)
If Len(LeFichier) = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If
Do While Len(LeFichier) <> 0
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = LeFichier
ActiveCell.Offset(1, -1).Select
LeFichier = Dir
Loop
'Compter le nombre de sous-répertoires
NbreRepert = 0
LeDossier = Dir(RepertParent, vbDirectory)
Do While LeDossier <> ""
If LeDossier <> "." And LeDossier <> ".." Then
If (GetAttr(RepertParent & LeDossier) And vbDirectory) = vbDirectory Then
NbreRepert = NbreRepert + 1
End If
End If
LeDossier = Dir
Loop
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
Do While LeDossierLocal(Compteur) <> ""
If LeDossierLocal(Compteur) <> "." And LeDossierLocal(Compteur) <> ".." Then
If (GetAttr(RepertParent & LeDossierLocal(Compteur)) And vbDirectory) = vbDirectory Then
Compteur = Compteur + 1
End If
End If
LeDossierLocal(Compteur) = Dir
Loop
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & "\"
Call remplir(ParentLocal, ExtLocale)
Next
End Sub
Sub mondir()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim LeMessage As String
Dim Arret As Boolean
LeTitre = "Répertoires et sous-répertoires"
LeMessage = "Taper le nom complet du répertoire"
Arret = False
Do
LeChemin = InputBox(LeMessage, LeTitre, LeChemin)
If Len(LeChemin) = 0 Then
Arret = True
Else
If Mid(LeChemin, Len(LeChemin), 1) <> "\" Then
LeChemin = LeChemin + "\"
End If
If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
Lextension = InputBox("Taper le type de fichier à afficher",
LeTitre, "*.*")
Call remplir(LeChemin, Lextension)
Arret = True
Else
LeMessage = "Répertoire introuvable...Recommencer ?"
End If
End If
Loop Until Arret
End Sub
Auteur inconnu. Transmis par
Isabelle, (N°1257)
Je voudrais lister les fichiers MP3 d'un répertoire et pouvoir mettre un lien hypertexte
pointant sur eux
Cette macro met le nom de fichier en colonne A et un lien hypertexte dans la colonne B.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim mess As String, mess2 As String, répertoire As String
Columns(1).Clear
Columns(2).Clear
mess = InputBox("entrez le nom du répertoire à explorer", "Chemin du
répertoire", _
"c:windowstemp") 'ThisWorkbook.Path)
mess2 = InputBox( _
"entrez le type de fichier ( _par exemple xls ou mid ou mp3 ou doc ou tmp ou
wav etc...)" _
, "TYPE DE FICHIER", "mp3")
Application.ScreenUpdating = False
répertoire = Dir(mess & "*" & mess2, vbDirectory)
Do While répertoire <> ""
i = i + 1
Cells(i, 1) = répertoire
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=mess &
répertoire
Cells(i, 2) = mess & répertoire
répertoire = Dir
Loop
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim mess As String, mess2 As String, répertoire As String
Columns(1).Clear
Columns(2).Clear
mess = InputBox("entrez le nom du répertoire à explorer", "Chemin du
répertoire", _
"c:windowstemp") 'ThisWorkbook.Path)
mess2 = InputBox( _
"entrez le type de fichier ( _par exemple xls ou mid ou mp3 ou doc ou tmp ou
wav etc...)" _
, "TYPE DE FICHIER", "mp3")
Application.ScreenUpdating = False
répertoire = Dir(mess & "*" & mess2, vbDirectory)
Do While répertoire <> ""
i = i + 1
Cells(i, 1) = répertoire
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=mess &
répertoire
Cells(i, 2) = mess & répertoire
répertoire = Dir
Loop
End Sub
Laurent Daures, (N°1256)
Je cherche une macro qui me liste tous les fichiers d'un répertoire quelconque
Sub zaza()
Set fs = Application.FileSearch
With fs
.LookIn = "C:Documents and SettingsflorenceApplication
DataMicrosoftExcel"
.Filename = "*"
.Execute
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
If .FoundFiles.Count = 0 Then
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
End Sub
*******************************
Si dans cette procédure j'écris :
.FileName = "F*.*"
Et bien j'obtiens tous les fichiers débutant par la lettre
F du répertoire choisi.
Si j'écris : .FileName = "F*"
J'obtiens seulement le nombre de fichiers dont les extensions font partie de la
constante "msoFileTypeOfficeFiles"
Set fs = Application.FileSearch
With fs
.LookIn = "C:Documents and SettingsflorenceApplication
DataMicrosoftExcel"
.Filename = "*"
.Execute
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
If .FoundFiles.Count = 0 Then
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
End Sub
*******************************
Si dans cette procédure j'écris :
.FileName = "F*.*"
Et bien j'obtiens tous les fichiers débutant par la lettre
F du répertoire choisi.
Si j'écris : .FileName = "F*"
J'obtiens seulement le nombre de fichiers dont les extensions font partie de la
constante "msoFileTypeOfficeFiles"
Denis Michon, Laurent Mortézai, Isabelle, (N°1255)
Comment récupérer l'arborescence d'un disque ou d'un répertoire dans un classeur Excel ?
Cette fonction (code Microsoft) t'intéressera sans doute. Elle renvoie dans un objet
Dictionary le nom et chemin complet des fichiers d'un répertoire (et si besoin de ses
sous-répertoires). Il est possible ensuite, à partir des items du dictionnaire, de mettre en
forme la sortie dans une feuille de calcul. (La fonction est accompagnée d'un exemple simple de
renvoi des résultats).
'utilise un objet Dictionary pour récupérer la liste des fichiers
'd'un répertoire et, en option, de ses sous-répertoires
'procédure exemple en fin de module
Function GetFiles(strPath As String, _
dctDict As Scripting.Dictionary, _
Optional blnRecursive As Boolean) As Boolean
'David Shank, Microsoft Corporation
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnofftalk/html/office09072000.asp
' This procedure returns all the files in a directory into
' a Dictionary object. If called recursively, it also returns
' all files in subfolders.
' La bibliothèque Microsoft Scripting Runtime
' doit être coché dans Outils\Références...
Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File
' Return new FileSystemObject.
Set fsoSysObj = New Scripting.FileSystemObject
On Error Resume Next
' Get folder.
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' Incorrect path.
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0
' Loop through Files collection, adding to dictionary.
For Each filFile In fdrFolder.Files
'récupère nom et chemin complet
dctDict.Add filFile.Path, filFile.Path
Next filFile
' If Recursive flag is true, call recursively.
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If
' Return True if no error occurred.
GetFiles = True
GetFiles_End:
Exit Function
End Function
' You can use the following procedure to test the GetFiles procedure.
' This procedure creates a new Dictionary object, passes it to the
' GetFiles procedure, then prints every file in the strDirPath directory
' and every file in any subdirectories to the immediate window.
Sub TestGetFiles()
' Call to test GetFiles function.
Dim dctDict As Scripting.Dictionary
Dim varItem As Variant
Dim strDirPath As String
strDirPath = "D:OfficeVBAModules\"
' Create new dictionary.
Set dctDict = New Scripting.Dictionary
' Call recursively, return files into Dictionary object.
If GetFiles(strDirPath, dctDict, True) Then
Sheets.Add
'récupère directement le tableau des items du dictionaire
'dans la colonne A de la nouvelle feuille
Range("A1:A" & dctDict.Count).Value = _
Application.Transpose(dctDict.Items)
End If
End Sub
Dictionary le nom et chemin complet des fichiers d'un répertoire (et si besoin de ses
sous-répertoires). Il est possible ensuite, à partir des items du dictionnaire, de mettre en
forme la sortie dans une feuille de calcul. (La fonction est accompagnée d'un exemple simple de
renvoi des résultats).
'utilise un objet Dictionary pour récupérer la liste des fichiers
'd'un répertoire et, en option, de ses sous-répertoires
'procédure exemple en fin de module
Function GetFiles(strPath As String, _
dctDict As Scripting.Dictionary, _
Optional blnRecursive As Boolean) As Boolean
'David Shank, Microsoft Corporation
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnofftalk/html/office09072000.asp
' This procedure returns all the files in a directory into
' a Dictionary object. If called recursively, it also returns
' all files in subfolders.
' La bibliothèque Microsoft Scripting Runtime
' doit être coché dans Outils\Références...
Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File
' Return new FileSystemObject.
Set fsoSysObj = New Scripting.FileSystemObject
On Error Resume Next
' Get folder.
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' Incorrect path.
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0
' Loop through Files collection, adding to dictionary.
For Each filFile In fdrFolder.Files
'récupère nom et chemin complet
dctDict.Add filFile.Path, filFile.Path
Next filFile
' If Recursive flag is true, call recursively.
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If
' Return True if no error occurred.
GetFiles = True
GetFiles_End:
Exit Function
End Function
' You can use the following procedure to test the GetFiles procedure.
' This procedure creates a new Dictionary object, passes it to the
' GetFiles procedure, then prints every file in the strDirPath directory
' and every file in any subdirectories to the immediate window.
Sub TestGetFiles()
' Call to test GetFiles function.
Dim dctDict As Scripting.Dictionary
Dim varItem As Variant
Dim strDirPath As String
strDirPath = "D:OfficeVBAModules\"
' Create new dictionary.
Set dctDict = New Scripting.Dictionary
' Call recursively, return files into Dictionary object.
If GetFiles(strDirPath, dctDict, True) Then
Sheets.Add
'récupère directement le tableau des items du dictionaire
'dans la colonne A de la nouvelle feuille
Range("A1:A" & dctDict.Count).Value = _
Application.Transpose(dctDict.Items)
End If
End Sub
Frédéric Sigonneau, (N°1250)