Recherche Nom d'un dossier

[redstoff]

Bonjour,

je cherche à la meme manière de

Code :

1
2
CheminFichier = "G:\Installation Peinture OM\Fiches Défauts\2011\11" & "\"
Fichier = Dir(CheminFichier & "*.xls")

trouver le nom des dossiers dans un répertoire.

Quelqu'un connait la méthode pour le faire?

Merci

[kiki29]

Salut, lire et adapter http://www.developpez.net/forums/d20...feuille-excel/ ou il s'agit de fichiers

Bref qqch comme ceci en n'oubliant pas de
Cocher Référence : Microsoft Scripting RunTime

ShDatas est le CodeName de la feuille recevant les données et non le nom d'onglet
Voir http://www.developpez.net/forums/d92...cel/vba-bases/

Code :

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
Option Explicit
 
Private Sub LectureDossiers(DossierRacine As String, iRow As Long, bSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim Dossier As Scripting.Folder
Dim SousDossier As Scripting.Folder
 
    Set FSO = New Scripting.FileSystemObject
    Set Dossier = FSO.GetFolder(DossierRacine)
 
    For Each SousDossier In Dossier.SubFolders
        iRow = iRow + 1
        ShDatas.Cells(iRow, 1).Value = SousDossier.Path
    Next SousDossier
 
    If bSousDossiers Then
        For Each SousDossier In Dossier.SubFolders
            LectureDossiers SousDossier.Path, iRow, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Sub Tst()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & Application.PathSeparator
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            ShDatas.Columns("A:A").ClearContents
            Application.ScreenUpdating = False
 
            LectureDossiers .SelectedItems(1), 0, True
 
            ShDatas.Range("B1").Select
            Application.ScreenUpdating = True
        End If
    End With
End Sub