Discussion :

[casdale]

Bonjour, je souhaite lister arborescence de dossier et de sous dossier dans un fichier Excel, j'aimerais que tous les fichiers d'un dossier soient dans la même colonne séparés par une "," jusqu'ici j'ai réussi.

Le problème se pose quand un dossier contient un sous dossier je souhaiterais récupérer le nom de arborescence précédente. Je m'explique voici un exemple de dossier :

[C:\Users\ordi\Documents\Doubsoccase\Travail\fitness\C1] C1 photoImport/C1/A49I0863.JPG, photoImport/C1/A49I0864.JPG, photoImport/C1/A49I0865.JPG, photoImport/C1/A49I0866.JPG
[C:\Users\ordi\Documents\Doubsoccase\Travail\fitness\C1\C11] C11 photoImport/C11/A49I0892.JPG, photoImport/C11/A49I0893.JPG
[C:\Users\ordi\Documents\Doubsoccase\Travail\fitness\C10] C10 photoImport/C10/A49I0888.JPG, photoImport/C10/A49I0889.JPG, photoImport/C10/A49I0890.JPG
[C:\Users\ordi\Documents\Doubsoccase\Travail\fitness\C11] C11 photoImport/C11/A49I0892.JPG, photoImport/C11/A49I0893.JPG, photoImport/C11/A49I0894.JPG


Ce que je souhaiterais c'est pour la ligne 2 le C11 j’obtienne

[C:\Users\ordi\Documents\Doubsoccase\Travail\fitness\C1\C11] C11 photoImport/C1/C11/A49I0892.JPG, photoImport/C1/C11/A49I0893.JPG

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Dim ligne
Sub arborescence()
  Application.ScreenUpdating = False
  racine = ChoixDossier()          ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A3:E20000").ClearContents
  Range("A3").Select
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = 3
 
    liens = ""
 
   virgule = 0
  Lit_dossier dossier_racine, 1
End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, 1) = "[" & dossier.Path & "]"
 
 
   For Each f In dossier.Files
 
 
 
  If virgule >= 1 Then
  liens = liens & ", " & "photoImport/" & dossier.Name & "/" & f.Name
  Else
 
      liens = liens & "photoImport/" & dossier.Name & "/" & f.Name
   End If
 
  virgule = virgule + 1
 
 
 
   Next
 
 
 
    Cells(ligne, 2) = dossier.Name
 
 
   Cells(ligne, 3) = liens
 
 
    ligne = ligne + 1
   For Each d In dossier.SubFolders
 
     Lit_dossier d, niveau + 1
 
   Next
   MsgBox " next"
End Sub
Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

pouvez vous m'aider a modifié mon code, la je suis un peu bloqué merci

[casdale]

Bonsoir, j'ai trouvé la solution par moi meme c'est pas tres propre comme progr mais cela fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
Dim ligne
Sub arborescence()
  Application.ScreenUpdating = False
  racine = ChoixDossier()          ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A3:E20000").ClearContents
  Range("A3").Select
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = 3
 tata = ""
   v = 0
  Lit_dossier dossier_racine, 1
  renomme
End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, 1) = "[" & dossier.Path & "]"
 
 
   test = test + 1
   For Each f In dossier.Files
 
 
 
  If v >= 1 Then
  'tata = tata & ", " & "photoImport/" & dossier.Name & "/" & f.Name
  tata = tata & ", " & dossier.Path & "\" & f.Name
  Else
     ' tata = tata & "photoImport/" & dossier.Name & "/" & f.Name
      tata = dossier.Path & tata & "\" & f.Name
   End If
 
  v = v + 1
 
 
      'tata = tata & "dossiercasz/" & dossier.Name & "/" & f.Name & ", "
   Next
 
 
  Cells(ligne, 2) = dossier.Name
 
     Cells(ligne, 3) = tata
   ' Cells(ligne, 3) = tata
    ' Cells(ligne, 3) = Cells(ligne, 3) & "toto"
 
    ligne = ligne + 1
   For Each d In dossier.SubFolders
 
     Lit_dossier d, niveau + 1
    Ndossier = d.Name
 
   Next
End Sub
Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function
 
Sub renomme()
'
' Macro2 Macro
'
 
'
    Columns("C:C").Select
    Selection.Replace What:="C:\Users\ordi\Desktop\C1", Replacement:= _
        "photoimport", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
End Sub