Liste de sous répertoires

Bonjour.
Va voir la la macro de Denis Michon ici :
http://www.excelabo.net/trucs/fichiers_et_tailles
à aménager suivant tes besoins.
Daniel

Bonjour à tous,

Sur un disque dur, j'ai un répertoire appelé Base.
Dans ce répertoire, j'ai x sous-répertoires.
Dans ces x sous-répertoires, j'ai aussi des sous-répertoires etc...

Serait-il, à partir du répertoire Base, de ne lister que les répertoires de
rang 1 ou que les répertoires de rang 2 etc...

J'espère avoir été assez clair.
Je suis parti de la proc. de MichDenis, mais elle liste tous les répertoires.
Pour mémoire, voir ci-dessous.

Public Ligne As Long

Sub ListeDossiers()

Path = H:Base
If Dir(Path, vbDirectory) = "" Then MsgBox "Dossier introuvable": Exit
Sub

Ligne = 13
Set fso = CreateObject("Scripting.FileSystemObject")
'Set dossier_racine = fso.GetFolder("H:Base")
Set dossier_racine = fso.getfolder(Path)
Lit_dossier_DVD dossier_racine

End Sub


Sub Lit_dossier (ByRef dossier)

Ligne = Ligne + 1
Cells(Ligne, 7) = dossier.Path
'Cells(Ligne, 7) = dossier.Name

'Range("A1").Offset(I + 3, 0) = Left(Right(.Item(I), Len(.Item(I)) -
Len(Path) - 1), Len(Right(.Item(I), Len(.Item(I)) - Len(Path) - 1)) - 4)

If Dir(dossier.Path, vbDirectory) <> "*_TS" Then Cells(Ligne, 7) = ""
'If Dir(dossier.Path, vbDirectory) = "*_TS" Then GoTo p1


'p1:
For Each d In dossier.subfolders
Lit_dossier_DVD d
Next

End Sub


Merci par avance pour vos éclairages.

Cordialement

Infogroup

Bonjour,

Essaie ceci :

Tu places tout ce qui suit dans un module standard.
Tu définis dans la procédure "test" le répertoire que
tu veux analyser
Et tu m'envoies ton chèque ! ;-)
'------------------------------------------------
Sub test()
Dim Répertoire As String, MaListe
Dim Temp(), Elt As Variant, A As Integer
Dim Sh As Worksheet

'Répertoire de départ à définir...
Répertoire = "C:UsersDM"

On Error Resume Next
Application.ScreenUpdating = False
If Dir(Répertoire, vbDirectory) <> "" Then
Set Sh = Worksheets.Add
MaListe = ListeDossiers(Répertoire, Temp())
With Sh
For Each Elt In MaListe
A = A + 1
.Range("A" & A) = Répertoire & "" & Elt
x = ListeDossiers(Répertoire & "" & Elt, Temp())
.Range("B" & A).Resize(UBound(x) + 1) = _
Application.Transpose(x)
A = A + UBound(x)
Next
.Range("A:B").EntireColumn.AutoFit = True
End With
End If
Application.ScreenUpdating = True
End Sub
'----------------------------------------
Function ListeDossiers(dossier, Liste())
Dim Fs As Object, F As Object
Dim F1 As Object, Sf As Object, A As Integer

Set Fs = CreateObject("Scripting.FileSystemObject")
Set F = Fs.GetFolder(dossier)
Set Sf = F.SubFolders

For Each F1 In Sf
ReDim Preserve Liste(0 To A)
Liste(A) = F1.Name
A = A + 1
Next
ListeDossiers = Liste

End Function
'----------------------------------------







"Infogroup" <regennasbernard@hotmail.com> a écrit dans le message de groupe de discussion
: eVbqzVusKHA.4816@TK2MSFTNGP02.phx.gbl...
Bonjour à tous,

Sur un disque dur, j'ai un répertoire appelé Base.
Dans ce répertoire, j'ai x sous-répertoires.
Dans ces x sous-répertoires, j'ai aussi des sous-répertoires etc...

Serait-il, à partir du répertoire Base, de ne lister que les répertoires de
rang 1 ou que les répertoires de rang 2 etc...

J'espère avoir été assez clair.
Je suis parti de la proc. de MichDenis, mais elle liste tous les
répertoires.
Pour mémoire, voir ci-dessous.

Public Ligne As Long

Sub ListeDossiers()

Path = H:Base
If Dir(Path, vbDirectory) = "" Then MsgBox "Dossier introuvable": Exit
Sub

Ligne = 13
Set fso = CreateObject("Scripting.FileSystemObject")
'Set dossier_racine = fso.GetFolder("H:Base")
Set dossier_racine = fso.getfolder(Path)
Lit_dossier_DVD dossier_racine

End Sub


Sub Lit_dossier (ByRef dossier)

Ligne = Ligne + 1
Cells(Ligne, 7) = dossier.Path
'Cells(Ligne, 7) = dossier.Name

'Range("A1").Offset(I + 3, 0) = Left(Right(.Item(I), Len(.Item(I)) -
Len(Path) - 1), Len(Right(.Item(I), Len(.Item(I)) - Len(Path) - 1)) - 4)

If Dir(dossier.Path, vbDirectory) <> "*_TS" Then Cells(Ligne, 7) = ""
'If Dir(dossier.Path, vbDirectory) = "*_TS" Then GoTo p1


'p1:
For Each d In dossier.subfolders
Lit_dossier_DVD d
Next

End Sub


Merci par avance pour vos éclairages.

Cordialement

Infogroup

| Va voir la la macro de Denis Michon ici :

Dis Daniel, tu connais un répondeur sur ce forum sous ce nom ?
Un imposteur ?
;-)

Bonjour,

Tu places tout ce qui suit dans un module standard.
Tu définis dans la procédure "test" le répertoire que
tu veux analyser
Et tu m'envoies ton chèque ! ;-)
(Message précédent annulé - utilise ceci)
'-----------------------------------------
Sub test()
Dim Répertoire As String, MaListe
Dim Temp(), Elt As Variant, A As Integer
Dim Sh As Worksheet

'Répertoire de départ à définir...
Répertoire = "C:UsersDM"

On Error Resume Next
Application.ScreenUpdating = False
If Dir(Répertoire, vbDirectory) <> "" Then
Set Sh = Worksheets.Add
MaListe = ListeDossiers(Répertoire, Temp())
Erase Temp
With Sh
For Each Elt In MaListe
A = A + 1
.Range("A" & A) = Répertoire & "" & Elt
x = ListeDossiers(Répertoire & "" & Elt, Temp())
.Range("B" & A).Resize(UBound(x) + 1) = _
Application.Transpose(x)
A = A + UBound(x)
Next
.Range("A:B").EntireColumn.AutoFit = True
End With
End If
Application.ScreenUpdating = True
End Sub
'-----------------------------------------
Function ListeDossiers(dossier, Liste())
Dim Fs As Object, F As Object
Dim F1 As Object, Sf As Object, A As Integer
Set Fs = CreateObject("Scripting.FileSystemObject")
Set F = Fs.GetFolder(dossier)
Set Sf = F.SubFolders

For Each F1 In Sf
ReDim Preserve Liste(0 To A)
Liste(A) = F1.Name
A = A + 1
Next
ListeDossiers = Liste
Erase Liste
End Function
'-----------------------------------------

Je sais pas qui c'est, mais il ya son nom au bas de la macro à
l'adresse indiquée. Ca doit être un gars qui fréquente pas le forum
;-)))
Daniel

Va voir la la macro de Denis Michon ici :

Dis Daniel, tu connais un répondeur sur ce forum sous ce nom ?
Un imposteur ?
;-)

il y a, par contre, un dénommé michel qui lui est très assidu
off record : c'est, faut bien le dire, une autre pointure que celui dont à quoi on cause...
jps

"Daniel.C" <dcolardelleZZZ@gmail.com> a écrit dans le message de news: u83bHEwsKHA.1796@TK2MSFTNGP02.phx.gbl...

Je sais pas qui c'est, mais il ya son nom au bas de la macro à l'adresse indiquée. Ca doit être un gars qui fréquente
pas le forum ;-)))
Daniel

Va voir la la macro de Denis Michon ici :

Dis Daniel, tu connais un répondeur sur ce forum sous ce nom ?
Un imposteur ?
;-)

;-)))
Daniel

il y a, par contre, un dénommé michel qui lui est très assidu
off record : c'est, faut bien le dire, une autre pointure que celui dont à
quoi on cause...
jps

"Daniel.C" <dcolardelleZZZ@gmail.com> a écrit dans le message de news:
u83bHEwsKHA.1796@TK2MSFTNGP02.phx.gbl...

Je sais pas qui c'est, mais il ya son nom au bas de la macro à l'adresse
indiquée. Ca doit être un gars qui fréquente pas le forum ;-)))
Daniel

Va voir la la macro de Denis Michon ici :

Dis Daniel, tu connais un répondeur sur ce forum sous ce nom ?
Un imposteur ?
;-)

Bonjour,

http://boisgontierjacques.free.fr/fichiers/Fichier/ArborescenceRepertoireSo usRep3.xls

JB

On 21 fév, 12:03, "Infogroup" <regennasbern...@hotmail.com> wrote:

Bonjour à tous,

Sur un disque dur, j'ai un répertoire appelé Base.
Dans ce répertoire, j'ai x sous-répertoires.
Dans ces x sous-répertoires, j'ai aussi des sous-répertoires etc...

Serait-il, à partir du répertoire Base, de ne lister que les répert oires de
rang 1 ou que les répertoires de rang 2 etc...

J'espère avoir été assez clair.
Je suis parti de la proc. de MichDenis, mais elle liste tous les
répertoires.
Pour mémoire, voir ci-dessous.

Public Ligne As Long

Sub ListeDossiers()

    Path = H:Base
    If Dir(Path, vbDirectory) = "" Then MsgBox "Dossier introuvable ": Exit
Sub

    Ligne = 13
    Set fso = CreateObject("Scripting.FileSystemObject")
    'Set dossier_racine = fso.GetFolder("H:Base")
    Set dossier_racine = fso.getfolder(Path)
    Lit_dossier_DVD dossier_racine

End Sub

Sub Lit_dossier (ByRef dossier)

     Ligne = Ligne + 1
     Cells(Ligne, 7) = dossier.Path
     'Cells(Ligne, 7) = dossier.Name

    'Range("A1").Offset(I + 3, 0) = Left(Right(.Item(I), Len(.Item( I)) -
Len(Path) - 1), Len(Right(.Item(I), Len(.Item(I)) - Len(Path) - 1)) - 4)

    If Dir(dossier.Path, vbDirectory) <> "*_TS" Then Cells(Ligne, 7) = ""
    'If Dir(dossier.Path, vbDirectory) = "*_TS" Then GoTo p1

'p1:
        For Each d In dossier.subfolders
          Lit_dossier_DVD d
        Next

End Sub

Merci par avance pour vos éclairages.

Cordialement

Infogroup

Un grand merci à Daniel.C et michdenis ( je ne dirai pas Denis Michon ! )

C'est OK pour moi

Cordialement

Infogroup


"Daniel.C" <dcolardelleZZZ@gmail.com> a écrit dans le message de groupe de
discussion : OkX#iLwsKHA.6004@TK2MSFTNGP04.phx.gbl...

;-)))
Daniel

il y a, par contre, un dénommé michel qui lui est très assidu
off record : c'est, faut bien le dire, une autre pointure que celui dont
à quoi on cause...
jps

"Daniel.C" <dcolardelleZZZ@gmail.com> a écrit dans le message de news:
u83bHEwsKHA.1796@TK2MSFTNGP02.phx.gbl...

Je sais pas qui c'est, mais il ya son nom au bas de la macro à l'adresse
indiquée. Ca doit être un gars qui fréquente pas le forum ;-)))
Daniel

Va voir la la macro de Denis Michon ici :

Dis Daniel, tu connais un répondeur sur ce forum sous ce nom ?
Un imposteur ?
;-)

| Mgr T. Banni
| il y a, par contre, un dénommé michel qui lui est très assidu
| off record : c'est, faut bien le dire, une autre pointure que
| celui dont à quoi on cause...

*** Continuer de diffamer Mgr, c'est moi qui vous le dis
ce n'est pas demain que vous serez canonisé!
;-)