Listage par niveaux de répertoires

Bonsoir,


http://boisgontierjacques.free.fr/fichiers/ArborescenceRepertoireSousRep.xl s

JB
http://boisgontierjacques.free.fr/

On 31 jan, 20:11, "Infogroup" <Infogrou...@orange.fr> wrote:

Bonsoir à tous,

dans un poste de hier Mishel m'a donné les proc. ci-dessous pour compte r les
sous répertoires de niveau 1, niveau 2, niveau 3 etc... par rapport à un
répertoire dont le chemin est en A1

Je voudrais aujourd'hui si c'est possible non seulement compter, mais aus si
lister les sous-répertoires de chaque niveau.

Dans l'affirmative, comment modifier les procédures ci-dessous.

Merci par avance

Cordialement

Infogroup

Dim Ligne
Dim niveaux()

Sub ListeDossiers() 'De Mishell

'Sheets("Édition liste fichiers").Select

    Columns("C").Clear
    Application.Wait (Now + TimeValue("0:00:02"))

    Ligne = 5

    ReDim niveaux(0)

    Set fso = CreateObject("Scripting.FileSystemObject")
    'Set dossier_racine = fso.GetFolder("c:aa")
    Set dossier_racine = fso.GetFolder(Range("A1").Value)
    Lit_dossier dossier_racine

    For I = 1 To UBound(niveaux)
     Ligne = Ligne + 1
     Cells(Ligne, 1) = "Niveau " & I
     Cells(Ligne, 2) = niveaux(I)
     ''Cells(Ligne, 3) = niveaux(I).Path

    Next

End Sub

Sub Lit_dossier(ByRef dossier)
     Ligne = Ligne + 1
     Cells(Ligne, 3) = dossier.Path

     Call Repertoires_par_niveau(dossier.Path)

   For Each D In dossier.SubFolders
     Lit_dossier D
   Next
End Sub

Sub Repertoires_par_niveau(chemin)

 Dim nombre As Long

debut = 1
nombre = 0
While InStr(debut, chemin, "") > 0

 nombre = nombre + 1
 debut = InStr(debut, chemin, "") + 1
Wend

If UBound(niveaux) < nombre Then
 ReDim Preserve niveaux(nombre)
End If
niveaux(nombre) = niveaux(nombre) + 1

End Sub

Merci JB pour ce fichier, ça convient tout à fait

Cdl

Infogroup


"JB" <boisgontier@hotmail.com> a écrit dans le message de
news:80ba2553-cb6f-4904-b9e2-745acabc4820@i20g2000prf.googlegroups.com...
Bonsoir,


http://boisgontierjacques.free.fr/fichiers/ArborescenceRepertoireSousRep.xls

JB
http://boisgontierjacques.free.fr/

On 31 jan, 20:11, "Infogroup" <Infogrou...@orange.fr> wrote:

Bonsoir à tous,

dans un poste de hier Mishel m'a donné les proc. ci-dessous pour compter
les
sous répertoires de niveau 1, niveau 2, niveau 3 etc... par rapport à un
répertoire dont le chemin est en A1

Je voudrais aujourd'hui si c'est possible non seulement compter, mais
aussi
lister les sous-répertoires de chaque niveau.

Dans l'affirmative, comment modifier les procédures ci-dessous.

Merci par avance

Cordialement

Infogroup

Dim Ligne
Dim niveaux()

Sub ListeDossiers() 'De Mishell

'Sheets("Édition liste fichiers").Select

Columns("C").Clear
Application.Wait (Now + TimeValue("0:00:02"))

Ligne = 5

ReDim niveaux(0)

Set fso = CreateObject("Scripting.FileSystemObject")
'Set dossier_racine = fso.GetFolder("c:aa")
Set dossier_racine = fso.GetFolder(Range("A1").Value)
Lit_dossier dossier_racine

For I = 1 To UBound(niveaux)
Ligne = Ligne + 1
Cells(Ligne, 1) = "Niveau " & I
Cells(Ligne, 2) = niveaux(I)
''Cells(Ligne, 3) = niveaux(I).Path

Next

End Sub

Sub Lit_dossier(ByRef dossier)
Ligne = Ligne + 1
Cells(Ligne, 3) = dossier.Path

Call Repertoires_par_niveau(dossier.Path)

For Each D In dossier.SubFolders
Lit_dossier D
Next
End Sub

Sub Repertoires_par_niveau(chemin)

Dim nombre As Long

debut = 1
nombre = 0
While InStr(debut, chemin, "") > 0

nombre = nombre + 1
debut = InStr(debut, chemin, "") + 1
Wend

If UBound(niveaux) < nombre Then
ReDim Preserve niveaux(nombre)
End If
niveaux(nombre) = niveaux(nombre) + 1

End Sub

Une autre façon de faire quant à l'affichage du résultat :
Ceci te permet de choisir un filtre et de voir le résultat.

'Variable dans le haut du module
Dim Sh As Worksheet, Ligne As Integer
'------------------------------------------
Sub ListeDossiers()
Ligne = 1
Set Sh = Worksheets("Feuil1") ' à définir
Sh.Cells.Clear
Set fso = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fso.getfolder("D:") 'à définir
Application.ScreenUpdating = False
On Error Resume Next
Lit_dossier dossier_racine
Mise_En_Forme
End Sub

Sub Lit_dossier(ByRef dossier)
Ligne = Ligne + 1
Sh.Cells(Ligne, 1) = dossier.Path
For Each d In dossier.SubFolders
Lit_dossier d
Next

End Sub
'------------------------------------------
Sub Mise_En_Forme()
Dim DerLig As Long, DerCol As Integer, A As Integer
Application.DisplayAlerts = False
With Sh
With .Columns("A:A").TextToColumns(Destination:=.Range("A1"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:úlse, Tab:úlse, Semicolon:úlse, _
Comma:úlse, Space:úlse, Other:=True, OtherChar:="", _
FieldInfo:=Array(Array(1, 9)))
End With
DerLig = .Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

DerCol = .Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column

With .Range("A2", .Cells(2, DerCol))
.Interior.Color = vbBlue
.HorizontalAlignment = xlCenter
For Each C In .Cells
A = A + 1
C.Value = "NIVEAU " & A
Next
If .AutoFilter Then .AutoFilter
.Offset(-1).Formula = "=subtotal(3," & Sh.Range("A2:A" & DerLig).Address(0, 0) &
")-1"
.Offset(-1).NumberFormat = "#,##0"" Répertoires"""
.Offset(-1).HorizontalAlignment = xlCenter
.AutoFilter
.EntireColumn.AutoFit
End With
End With
End Sub
'------------------------------------------





"Infogroup" <Infogroup70@orange.fr> a écrit dans le message de groupe de discussion :
ujH83e9gJHA.2384@TK2MSFTNGP04.phx.gbl...
Bonsoir à tous,

dans un poste de hier Mishel m'a donné les proc. ci-dessous pour compter les
sous répertoires de niveau 1, niveau 2, niveau 3 etc... par rapport à un
répertoire dont le chemin est en A1

Je voudrais aujourd'hui si c'est possible non seulement compter, mais aussi
lister les sous-répertoires de chaque niveau.

Dans l'affirmative, comment modifier les procédures ci-dessous.

Merci par avance

Cordialement

Infogroup



Dim Ligne
Dim niveaux()

Sub ListeDossiers() 'De Mishell

'Sheets("Édition liste fichiers").Select

Columns("C").Clear
Application.Wait (Now + TimeValue("0:00:02"))

Ligne = 5

ReDim niveaux(0)

Set fso = CreateObject("Scripting.FileSystemObject")
'Set dossier_racine = fso.GetFolder("c:aa")
Set dossier_racine = fso.GetFolder(Range("A1").Value)
Lit_dossier dossier_racine

For I = 1 To UBound(niveaux)
Ligne = Ligne + 1
Cells(Ligne, 1) = "Niveau " & I
Cells(Ligne, 2) = niveaux(I)
''Cells(Ligne, 3) = niveaux(I).Path

Next

End Sub

Sub Lit_dossier(ByRef dossier)
Ligne = Ligne + 1
Cells(Ligne, 3) = dossier.Path

Call Repertoires_par_niveau(dossier.Path)

For Each D In dossier.SubFolders
Lit_dossier D
Next
End Sub

Sub Repertoires_par_niveau(chemin)

Dim nombre As Long

debut = 1
nombre = 0
While InStr(debut, chemin, "") > 0

nombre = nombre + 1
debut = InStr(debut, chemin, "") + 1
Wend

If UBound(niveaux) < nombre Then
ReDim Preserve niveaux(nombre)
End If
niveaux(nombre) = niveaux(nombre) + 1

End Sub

Bien vu michdenis,

effectivement la présentation est plus clair et plus lisible

Merci infiniment

Cdl

Infogroup



"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:3725262A-59E9-4E19-AE9E-7CAE2A570978@microsoft.com...

Une autre façon de faire quant à l'affichage du résultat :
Ceci te permet de choisir un filtre et de voir le résultat.

'Variable dans le haut du module
Dim Sh As Worksheet, Ligne As Integer
'------------------------------------------
Sub ListeDossiers()
Ligne = 1
Set Sh = Worksheets("Feuil1") ' à définir
Sh.Cells.Clear
Set fso = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fso.getfolder("D:") 'à définir
Application.ScreenUpdating = False
On Error Resume Next
Lit_dossier dossier_racine
Mise_En_Forme
End Sub

Sub Lit_dossier(ByRef dossier)
Ligne = Ligne + 1
Sh.Cells(Ligne, 1) = dossier.Path
For Each d In dossier.SubFolders
Lit_dossier d
Next

End Sub
'------------------------------------------
Sub Mise_En_Forme()
Dim DerLig As Long, DerCol As Integer, A As Integer
Application.DisplayAlerts = False
With Sh
With .Columns("A:A").TextToColumns(Destination:=.Range("A1"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:úlse, Tab:úlse, Semicolon:úlse, _
Comma:úlse, Space:úlse, Other:=True, OtherChar:="", _
FieldInfo:=Array(Array(1, 9)))
End With
DerLig = .Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

DerCol = .Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column

With .Range("A2", .Cells(2, DerCol))
.Interior.Color = vbBlue
.HorizontalAlignment = xlCenter
For Each C In .Cells
A = A + 1
C.Value = "NIVEAU " & A
Next
If .AutoFilter Then .AutoFilter
.Offset(-1).Formula = "=subtotal(3," & Sh.Range("A2:A" &
DerLig).Address(0, 0) &
")-1"
.Offset(-1).NumberFormat = "#,##0"" Répertoires"""
.Offset(-1).HorizontalAlignment = xlCenter
.AutoFilter
.EntireColumn.AutoFit
End With
End With
End Sub
'------------------------------------------





"Infogroup" <Infogroup70@orange.fr> a écrit dans le message de groupe de
discussion :
ujH83e9gJHA.2384@TK2MSFTNGP04.phx.gbl...
Bonsoir à tous,

dans un poste de hier Mishel m'a donné les proc. ci-dessous pour compter
les
sous répertoires de niveau 1, niveau 2, niveau 3 etc... par rapport à un
répertoire dont le chemin est en A1

Je voudrais aujourd'hui si c'est possible non seulement compter, mais
aussi
lister les sous-répertoires de chaque niveau.

Dans l'affirmative, comment modifier les procédures ci-dessous.

Merci par avance

Cordialement

Infogroup



Dim Ligne
Dim niveaux()

Sub ListeDossiers() 'De Mishell

'Sheets("Édition liste fichiers").Select

Columns("C").Clear
Application.Wait (Now + TimeValue("0:00:02"))

Ligne = 5

ReDim niveaux(0)

Set fso = CreateObject("Scripting.FileSystemObject")
'Set dossier_racine = fso.GetFolder("c:aa")
Set dossier_racine = fso.GetFolder(Range("A1").Value)
Lit_dossier dossier_racine

For I = 1 To UBound(niveaux)
Ligne = Ligne + 1
Cells(Ligne, 1) = "Niveau " & I
Cells(Ligne, 2) = niveaux(I)
''Cells(Ligne, 3) = niveaux(I).Path

Next

End Sub

Sub Lit_dossier(ByRef dossier)
Ligne = Ligne + 1
Cells(Ligne, 3) = dossier.Path

Call Repertoires_par_niveau(dossier.Path)

For Each D In dossier.SubFolders
Lit_dossier D
Next
End Sub

Sub Repertoires_par_niveau(chemin)

Dim nombre As Long

debut = 1
nombre = 0
While InStr(debut, chemin, "") > 0

nombre = nombre + 1
debut = InStr(debut, chemin, "") + 1
Wend

If UBound(niveaux) < nombre Then
ReDim Preserve niveaux(nombre)
End If
niveaux(nombre) = niveaux(nombre) + 1

End Sub