Lister les fichiers d'un dossier

[LaurentG]

Bonjour,

J'aimerais avoir une macro qui me liste les fichiers qui se trouve dans un dossier et qui me met les noms des fichiers dans une feuille Excel, l'un en dessous de l'autre avec l'extension.

quelqu'un a une idée?

Merci beaucoup

Laurent

 

[Bebere]

bonjour Laurent

Attribute VB_Name = 'ExtraireNomsClasseursEtFeuilles'
'Question :
'Comment extraire une liste de fichier dans un repertoire et
'si les fichiers sont de types .XLS alors comment extraire le nom de toutes
'les feuilles dans ce fichier
'Solution de papou, mpfe (code à adapter suivant besoin)

Sub lancer()
Dim noms_de_fichiers As Variant, i As Integer, y As Integer

Application.ScreenUpdating = False

ChDrive 'D' 'Modifie la lettre du lecteur
ChDir 'D:\\Mes Documents' 'Modifie le répertoire
noms_de_fichiers = créer_liste_fichiers('*.xls')
Workbooks('Classeur4.xls').Activate 'Modifie le nom du classeur
Sheets('Feuil1').Select 'Modifie le nom de la feuille
Range('A1', Range('A1').End(xlDown)).Select
Selection.ClearContents
Range('A1').Select

For i = 1 To UBound(noms_de_fichiers)
Cells(i, 1).Formula = noms_de_fichiers(i)
Next i

Dim currentcell, nextcell
Set currentcell = Worksheets('Feuil1').Range('A1') 'Modifie le nom de la feuille
Do While Not IsEmpty(currentcell)
Dim nom_fichier
Set nextcell = currentcell.Offset(1, 0)
nom_fichier = currentcell.Value
Workbooks.Open (nom_fichier)
For y = 1 To ActiveWorkbook.Sheets.Count
'Dans la ligne ci-dessous modifie éventuellemnt les noms de classeur et de feuille
Workbooks('Classeur4.xls').Sheets('Feuil2').Cells(y, 1).Formula = _
ActiveWorkbook.name & ActiveWorkbook.Sheets(y).name
Next y
ActiveWorkbook.Close
Set currentcell = nextcell
Loop
Application.ScreenUpdating = True
End Sub

Public Function créer_liste_fichiers(Filtre As String)

'===========================================================================
'Fonction permettant de générer une liste des fichiers présents dans le
'répertoire courant
'Cette liste va être générée dans la procédure Lancer
'===========================================================================

Dim listefichiers() As String, comptefichier As Long
créer_liste_fichiers = ''
Erase listefichiers
If Filtre = '' Then Filtre = '*.xls'
With Application.FileSearch
.NewSearch
.LookIn = CurDir
.Filename = Filtre
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, _
sortorder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim listefichiers(.FoundFiles.Count)
For comptefichier = 1 To .FoundFiles.Count
listefichiers(comptefichier) = .FoundFiles(comptefichier)
Next comptefichier
.FileType = msoFileTypeExcelWorkbooks
End With
créer_liste_fichiers = listefichiers
Erase listefichiers
End Function
à bientôt

 

[Hervé]

Bonsoir laurent, bebere

une autre solution peut etre un peu plus courte.

Sub Bouton1_QuandClic()
Dim chemin As String
Dim fichier As String
Dim ligne As Integer

ligne = 1
chemin = 'c:\\\\\\\\Aherve\\\\\\\\'
fichier = Dir(chemin & '*.XLS')
Do While fichier DIFFERENT ''
Cells(ligne, 1) = fichier: ligne = ligne + 1
fichier = Dir
Loop
End Sub

remplacer DIFFERENT par le signe équivalent.

salut

Message édité par: hervé, à: 09/02/2006 18:41

 

[_Thierry]

Bonsoir Hervé, Bébère, Laurent

Sorry de m'incruster, mais comment passes-tu les Anti-Slash Hervé ? le tag & # 9 2 ;

\Test\

\\Test\\
Ne semblait plus fonctionner

Merci à toi
[ol]@+Thierry[/ol]

 

[Hervé]

re tout le monde


thierry, je les quadruples \\\\\\\\



salut

 

[_Thierry]

Bonjour cher ami Hervé, le fil, le Forum

\\\\\\\\MERCI\\\\\\\\HERVE\\\\\\\\ LOL

Je te dois une pinte au NinKaZi !!!

Bonne Journée
[ol]@+Thierry[/ol]