Lister des fichiers sous conditions en VBA

**maximilien59** · 02/09/2020, 16h20

Bonjour a tous,

Je me permet de vous contactez,du fait que, je suis bloqué sur ma programmation.

Le but de ma programmation est de répertorier tout les fichiers d'une machine de tests de ma société, afin de vérifier a distance si le fonctionnement s'effectue en MANU ou AUTO afin de mettre en place des indicateurs.

J'ai réussi à lister les fichiers du répertoire et mettre en place les conditions sur mon fichier "test programmation"

Par contre quand je met en place la programmation en réel, cela bloque, du fait que la liste " test reel" de la société contient des fichiers test, mais aussi d'autre fichier "reglage" par exemple.

Pour remédier à cela, Je voudrais lire que les noms de fichiers contenant que les caractères (pe,pi,po) avant d'importer les données?

Est-ce que cela est possible?

Je vous remercie

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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
Option Explicit
 
Const Dossier As String = "C:\Desktop\Nouveau dossier (2)\Nouveau dossier" ' <<<<<<<<<<<<   A Adapter
 
Sub TestListeFichiers()
 
 'Mise à zero de la pagecomp
   Cells.Select
   Selection.ClearContents
 
 
'    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).
 
    'Appelle la procédure de recherche des fichiers
    ListeFichiers Dossier
 
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
    Columns("A:E").AutoFit
    MsgBox "Terminé"
 
End Sub
 
Sub ListeFichiers(Repertoire As String)
Dim ThePath As String
Dim Record As String
Dim Container As Variant
Dim NbData As Long, NbLines As Long, NbLine1 As Long, NbLine2 As Long, NbLineAutre As Long, NbLineData As Long
Dim MyDate As Date
 
    '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 SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
 MyDate = #7/23/2020# '<<< Attention Format Américain MM/DD/YYYY
 'MyDate = Date
 
 
 'Mise à zero de la page
'    Cells.Select
'    Selection.ClearContents
 
 'Titre des colonnes
    Range("a1").Value = "Nom du fichier"
    Range("b1").Value = "Date de modification"
    Range("c1").Value = "Nombre de données fichier"
    Range("d1").Value = "Nombre de Ligne total du fichier"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("e1").Value = "Nombre de Ligne contenant un '1'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("f1").Value = "Nombre de Ligne contenant un '2'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("g1").Value = "Nombre de Ligne contenant autre chose"
    Range("i1").Value = "% Auto"
    Range("j1").Value = "% Manu"
 
 'Mise en forme 1er ligne
 
    Rows("1:1").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 12
 
    '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
 
 
    If DatePart("yyyy", FileItem.DateLastModified) = DatePart("yyyy", Date) Then
    'If CDate(FileItem.DateLastModified) >= MyDate Then
 
              '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
 
              'Indique la date de dernière modification
              Cells(i, 2) = FileItem.DateLastModified
 
 
                  ThePath = Repertoire & "\" & FileItem.Name
                  Open ThePath For Input As #1
 
                  Do While Not EOF(1)
                      Line Input #1, Record
                      NbData = NbData + 1
                          If Record <> "" Then
                              NbLines = NbLines + 1
 
                                  If NbLines >= 2 Then
                                  NbLineData = NbLineData + 1
                                      Container = Split(Record, Chr(59)) '<<<<<<<<<<  C'est le ; !!! Plus le Tab !!! http://www.asciitable.com/
                                      If Container(1) = 1 Then NbLine1 = NbLine1 + 1
                                      If Container(1) = 2 Then NbLine2 = NbLine2 + 1
                                      If Container(1) <> 1 And Container(1) <> 2 Then NbLineAutre = NbLineAutre + 1
                                  End If
                          End If
                  Loop
              Close #1
              Cells(i, 3) = NbData
              Cells(i, 4) = NbLineData
              Cells(i, 5) = NbLine1
              Cells(i, 6) = NbLine2
              Cells(i, 7) = NbLineAutre
              Cells(i, 9) = (NbLine1 / NbData) * 100  ' Delta Auto
              Cells(i, 10) = (NbLine2 / NbData) * 100 ' delta Manu
 
 
              NbData = 0
              NbLines = 0
              NbLine1 = 0
              NbLine2 = 0
              NbLineAutre = 0
              NbLineData = 0
 
               'Range("A2:G1000").Select
               'Range("a2").Activate
               'Selection.Cut Destination:=Range("A3:G1001")
               'Range("A3:G1001").Select
 
              i = i + 1
 
 
    Else
    'Do Nothing
    End If
 
 
 
    Next FileItem
 
 
    '-Mise a forme conditionnelle
 
    'Colonne "i"
'
    Range("I2:I10000").Select
    Selection.FormatConditions.AddColorScale ColorScaleType:=3
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
        xlConditionValueLowestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
        .Color = 7039480
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
        xlConditionValuePercentile
    Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
    With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
        .Color = 16776444
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
        xlConditionValueHighestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
        .Color = 8109667
        .TintAndShade = 0
    End With
 
 
  'Colonne "j"
 
    Range("J2:J10000").Select
    Selection.FormatConditions.AddColorScale ColorScaleType:=3
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
        xlConditionValueLowestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
        .Color = 8109667
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
        xlConditionValuePercentile
    Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
    With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
        .Color = 8711167
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
        xlConditionValueHighestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
        .Color = 7039480
        .TintAndShade = 0
    End With
 
 
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder
 
 Range("a1").Select
 
End Sub

**Menhir** · 02/09/2020, 18h04

Mets en ligne 84 :

Code :

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

If InStr(FileItem.Name, "pe") > 0 Or InStr(FileItem.Name, "pi") > 0 Or InStr(FileItem.Name, "po") > 0 Then

Et en ligne 136 :

Code :

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

End If

Et vire le Else de la ligne 138, il ne sert à rien.

**maximilien59** · 03/09/2020, 10h03

Merci pour la réponse et de la rapidité.

Je clôture la discussion.

Lister des fichiers sous conditions en VBA [XL-2013]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager