Liste de sous répertoires

Le
Infogroup
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
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Daniel.C
Le #21241061
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


michdenis
Le #21241211
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" :
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
michdenis
Le #21241201
| Va voir la la macro de Denis Michon ici :

Dis Daniel, tu connais un répondeur sur ce forum sous ce nom ?
Un imposteur ?
;-)
michdenis
Le #21241191
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
'-----------------------------------------
Daniel.C
Le #21241181
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
Le #21241281
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"
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.C
Le #21241271
;-)))
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"
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 ?
;-)








JB
Le #21241561
Bonjour,

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

JB

On 21 fév, 12:03, "Infogroup"
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


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

C'est OK pour moi

Cordialement

Infogroup


"Daniel.C" discussion : OkX#
;-)))
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"
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 ?
;-)












michdenis
Le #21242861
| 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é!
;-)
Publicité
Poster une réponse
Anonyme