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
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
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
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
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
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" a écrit dans le message de groupe de
discussion :
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
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" a écrit dans le message de groupe de
discussion :
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