Discussion :

[nivk-539]

Bonjour,

Je recherche un programme VBA grâce auquel je pourrai récupérer le nom d'un dossier (Nomdossier) et le mettre automatiquement dans une cellule ainsi qu'à la place du nom de ma feuille.
Par exemple:
J'ai un dossier sur mon bureau avec des fichiers pdfs à l'intérieur (Nomfichier_1 , Nomfichier_2 etc....).
J'aimerais, grâce à un input box, entrer le nom de mon dossier (Nomdossier), que ce nom s'affiche dans une cellule ainsi qu'à la place du nom de ma feuille et que mes fichiers pdfs
s'affichent aussi dans des cellules avec le nom du fichier et le lien pdf.
Etant novice, je ne sais pas par où commencer. si quelqu'un peut m'aider ça serait un plaisir!

[MarcelG]

Bonjour,

Avant tout, tu peux consulter la FAQ
FAQ Développez Fichiers

Pour ma part, à partir de cette source, et peut-être d'une ou deux discussions, j'avais développé ce code

(à adapter)

Ne pas oublier d'activer la Référence Microsoft Scripting.Runtime (Menu Outils\Références dans ton éditeur VBE).

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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
Option Explicit
Dim lign As Integer
 
Public Sub ListeFichiersRépertoire()
 
Dim Dossier As String
Dim ligndép As Integer
Dim libel As Range
Dim pos As Integer
Dim champ As Range
Dim c As Range
 
Application.ScreenUpdating = False
 
Dossier = InputBox("Entrer le dossier dont vous voulez lister les Fichiers", "Choix du Répertoire")
If Dossier = "" Then Exit Sub
ActiveWindow.SplitRow = 0
 
'ligne de titres
 ligndép = 2
 
With ThisWorkbook.Worksheets("Liste")
 
        .UsedRange.Clear
        'Rows("1:2").Delete Shift:=xlUp
        .Range(.Cells(ligndép - 1, 1), .Cells(ligndép, 1).End(xlToRight).End(xlDown)).Clear
 
        'Liste des Fichiers
        lign = ligndép
        Call ListeFichiers(Dossier)
 
        .Rows(ligndép - 1 & ":" & ligndép - 1).Insert Shift:=xlDown
        Set libel = .Range("A" & ligndép - 1)
        With libel
                .Value = "Liste des fichiers contenus dans la ressource " & Dossier
                With .Font
                        .Name = "Arial Black"
                        .Size = 12
                        .ColorIndex = 5
                End With
                pos = InStr(.Value, "\\")
                .Characters(pos, Len(libel) - pos + 1).Font.ColorIndex = 3
                .RowHeight = 30
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlCenter
        End With
        With .Range("A" & ligndép)
                .Offset(0, 0).Value = "Sous Répertoire 1"
                .Offset(0, 1).Value = "Nom complet"
                .Offset(0, 2).Value = "Nom"
                .Offset(0, 3).Value = "Taille"
                .Offset(0, 4).Value = "Type"
                .Offset(0, 5).Value = "Création"
                .Offset(0, 6).Value = "Modification"
                .Offset(0, 7).Value = "Dernier accès"
                .Offset(0, 8).Value = "Attribut"
                .Offset(0, 9).Value = "Répertoire court"
                .Offset(0, 10).Value = "Nom court"
        End With
        .Range("A" & ligndép + 1 & ":K" & ligndép + 1).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
        With .Range(libel.Offset(1, 0), libel.Offset(1, 0).End(xlToRight))
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
        End With
        Set champ = .Range(libel.Offset(2, 0), libel.Offset(2, 0).End(xlToRight).End(xlDown))
        For Each c In champ
                With c
                        .Value = Replace(.Value, Dossier, "")
                End With
        Next c
        With champ
                With .Offset(-1, 0).Resize(.Rows.Count + 1)
                        .Columns.AutoFit
                        .RowHeight = 15
                        .VerticalAlignment = xlCenter
                        .Borders(xlDiagonalDown).LineStyle = xlNone
                        .Borders(xlDiagonalUp).LineStyle = xlNone
                        .Borders(xlEdgeLeft).Weight = xlMedium
                        .Borders(xlEdgeTop).Weight = xlMedium
                        .Borders(xlEdgeBottom).Weight = xlMedium
                        .Borders(xlEdgeRight).Weight = xlMedium
                        .Borders(xlInsideVertical).Weight = xlMedium
                        .Borders(xlInsideHorizontal).Weight = xlThin
                End With
        End With
        Set champ = Nothing
        Set libel = Nothing
End With
Call Sépare_dossier
With ActiveWindow
        .SplitRow = 2
        .FreezePanes = True
End With
 
End Sub
 
Sub ListeFichiers(Repertoire As String)
    '
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
'Dans l'éditeur de macros (Alt+F11):
'Menu Outils
'Références
'Cochez la ie "Microsoft Scripting RunTime".
'Cliquez sur le bouton OK pour valider.
 
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim classeur As Scripting.File
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
 
 
'Boucle sur tous les fichiers du répertoire
For Each classeur In SourceFolder.Files
 
        'Nom du répertoire
        Cells(lign, 1) = classeur.ParentFolder.Path
 
        'Nom du répertoire + Nom du classeur
        'Cells(lign, 2) = classeur.Path
 
        'nom du fichier
        Cells(lign, 3) = classeur.Name
 
        'Ajoute un lien hypertexte vers le fichier
        'ActiveSheet.Hyperlinks.Add Anchor:=Cells(lign, 3), _
        Address:=classeur.ParentFolder & "\" & classeur.Name
 
        'Taille du Classeur
        Cells(lign, 4) = classeur.Size
 
        'Type du classeur
        Cells(lign, 5) = classeur.Type
 
        'Date de création
        Cells(lign, 6) = Format(classeur.DateCreated, "dd:mm:yy"" à ""hh:mm")
 
        'Date de dernière modification
        Cells(lign, 7) = Format(classeur.DateLastModified, "dd:mm:yy"" à ""hh:mm")
 
        'Date de dernier accès
        Cells(lign, 8) = Format(classeur.DateLastAccessed, "dd:mm:yy"" à ""hh:mm")
 
        'Atribut
        'Cells(lign, 9) = classeur.Attributes
 
        'Répertoire court
        'Cells(lign, 10) = classeur.ShortPath
 
        'Nom court
        'Cells(lign, 11) = classeur.ShortName
 
        lign = lign + 1
 
Next classeur
 
 
'--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
For Each SubFolder In SourceFolder.SubFolders
        ListeFichiers SubFolder.Path
Next SubFolder
 
End Sub

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
Option Explicit
Option Base 1
 
Public Sub Sépare_dossier()
 
Dim derlign As Integer
Dim maxcol As Byte
Dim i As Integer
Dim u As Variant
Dim k As Byte
 
Dim tch As Variant
 
 
With Worksheets("Liste")
        derlign = .Cells(.Rows.Count, 1).End(xlUp).Row
        maxcol = 1
        For i = 3 To derlign
                u = UBound(Split(Replace(.Range("A" & i), "\\", "\"), "\"))
                maxcol = IIf(u > maxcol, u, maxcol)
        Next
        For i = 1 To maxcol - 1
            .Columns(2).Insert Shift:=xlToRight
        Next i
        For i = 2 To maxcol
                .Cells(2, i).Value = "Sous Répertoire " & i
        Next i
        For i = 3 To derlign
                tch = Split(Replace(.Range("A" & i), "\\", "\"), "\")
                For k = 1 To UBound(tch)
                        .Cells(i, k).Value = tch(k)
                Next k
        Next i
End With
End Sub

[Rémy.A]

Bonjour Kev,

Je peux te proposer un bout de code que j'ai réalisé.
Il faut le mettre en événement sur ta feuille.

Dans l'exemple ça s'applique pour la cellule A1.

Après tu récupère la valeur de A1 et il faut faire un bout de code pour renommer ta feuille.

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
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
Dim FichierDeMaj As String
Dim chemin As String
Dim ext As String
Dim fileExt
 
 
If Not Intersect(Target, Range("A1")) Is Nothing And A1 = "" Then
 
FichierDeMaj = Application.GetOpenFilename("Tous,*.*", , "Choisir un fichier ...")
 
'Si on veut le chemin
chemin = Left(FichierDeMaj, InStrRev(FichierDeMaj, Application.PathSeparator) - 1)
 
'On extrait le nom du chemin complet
FichierDeMaj = Right(FichierDeMaj, Len(FichierDeMaj) - InStrRev(FichierDeMaj, Application.PathSeparator))
 
'On split sur le . pour extraire le nom et l'extension
Range("A1") = FichierDeMaj
 
Debug.Print chemin
Debug.Print FichierDeMaj
 
End If
End Sub

[nivk-539]

Parfait merci beaucoup ça marche