1 pièce(s) jointe(s)
Macro Liste fichiers d'un répertoire avec exception
Bonjour,
Je suis niveau débutant en VBA et grâce à ce forum ainsiqu'à vos contributions, j'ai commencé à réaliser une plateforme de documents portant sur des fichiers éparpillés dans plusieurs dossiers et sous dossiers.
Afin que celle-ci se mette à jour le plus simplement possible, j'ai placé sous chaque répertoire un fichier excel (se nommant SYSTEME_Outil_MAJ_auto *** 1 ou 2 ou 3, etc ...) qui, à l'ouverture, liste automatiquement les fichiers présents sous le répertoire et sauvegarde.
Un autre fichier excel (nommé Outil_MAJ) est chargé d'ouvrir tout les fichiers excel puis de les fermer les un à la suite des autres afin de les lancer, d'exécuter leurs macros, de sauvegarder la mise à jour puis de les fermer.
Seulement, je souhaiterais que le fichier excel SYSTEME_Outil_MAJ_auto *** ne tienne pas compte de lui même dans le listage des fichiers présent sous répertoire.
Code :
Code:
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
|
Private Sub Workbook_Open()
'Lance les macro à l'ouverture et sauvegarde automatiquement
Call MAJ
'Enregistre les modifications du fichier contenant la macro
ThisWorkbook.Save
End Sub
Sub MAJ()
'Lance la macro Clear puis TestListeFichiers
Call Clear
Call TestListeFichiers
Call ListeFichiers(ActiveWorkbook.Path)
End Sub
Sub Clear()
'Efface tout les précédents enregistrements
ActiveSheet.Shapes.SelectAll
Selection.Delete
ActiveSheet.Cells.Clear
End Sub
Sub TestListeFichiers()
Dim Dossier As String
'Définit le répertoire pour débuter la recherche de fichiers.
'(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de
'fichiers, sinon le temps de traitement va être très long).
Dossier = ActiveWorkbook.Path
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 ligne "Microsoft Scripting RunTime".
'Cliquez sur le bouton OK pour valider.
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder
Dim FileItem As Scripting.File
Dim i As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
'Récupère le numéro de la dernière ligne vide dans la colonne A.
i = Range("A65536").End(xlUp).Row + 1
'Boucle sur tous les fichiers du répertoire
For Each FileItem In SourceFolder.Files
'Inscrit le nom du fichier dans la cellule
Cells(i, 1) = FileItem.Name
'Ajoute un lien hypertexte vers le fichier
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
Address:=FileItem.ParentFolder & "\" & FileItem.Name
'Nom du répertoire
Cells(i, 2) = FileItem.ParentFolder
i = i + 1
Next FileItem
End Sub |
J'ai pas mal cherché par moi même depuis 4-5 jours mais mon niveau de compétence m'a freiné...
D'avance merci pour vos efforts!
Le fichier est en pièce jointe.
