[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