Discussion :

[QuestVba]

Bonjour, Forum,

J'utilise ce code pour lister tous les fichiers PDF d'un répertoire. J'ai ajouté quelques éléments qui me sont nécessaires.

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
'Option Explicit
 
Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
  ' adapté de Ole P Erlandsen
  ' necessite d'activer la reference Microsoft Scripting RunTime
  Static FSO As FileSystemObject
  Dim oSourceFolder As Scripting.Folder
  Dim oSubFolder As Scripting.Folder
  Dim oFile As Scripting.File
  Static wksDest As Worksheet
  Dim iRow As Long
  Static bNotFirstTime As Boolean
 
 
    Set wksDest = ActiveSheet
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
 
  Set oSourceFolder = FSO.GetFolder(strFolderName)
  For Each oFile In oSourceFolder.Files
 
    If Right(oFile.Name, 3) = "PDF" Then
    iRow = wksDest.Range("A65536").End(xlUp).Row + 1
    wksDest.Cells(iRow, 1) = oFile.ParentFolder.Path
    wksDest.Cells(iRow, 2) = oFile.Name
    'Ajout lien hypertexte
    With ActiveSheet
    .Hyperlinks.Add Anchor:=.Cells(iRow, 3), _
    Address:=oFile.ParentFolder.Path & "\" & oFile.Name, _
    TextToDisplay:=Mid(oFile.Name, 3, 7)
    'Date création
    'wksDest.Cells(iRow, 66) = oFile.DateCreated
    End With
    End If
 
  Next oFile
 
'  For Each oSubFolder In oSourceFolder.SubFolders
    ' On peut mettre ici un traitement spécifique pour les dossiers
'  Next oSubFolder
 
  If bIncludeSubfolders Then
    For Each oSubFolder In oSourceFolder.SubFolders
      ListFilesInFolder oSubFolder.Path, True
    Next oSubFolder
  End If
 
End Sub
Sub Test()
 
'Quel jour sommes-nous?
Dim Jour As String
Dim c As String
 Jour = UCase(Left(Format(Now(), "dddd"), 1)) & Mid(LCase(Format(Now(), "dddd")), 2)
 c = Weekday(Now(), 2)
 Select Case c
        Case 1
            Jours = "Monday"
        Case 2
            Jours = "Tuesday"
        Case 3
            Jours = "Wednesday"
        Case 4
            Jours = "Thursday"
        Case 5
            Jours = "Friday"
    End Select
 
'Nettoyage de la feuille
    Dim Endline
    Sheets("Check_" & Jours).Activate
    If Cells(2, 1).Value = "" Then Endline = 2 Else Endline = ActiveWorkbook.Sheets("Check_" & Jours).Range("A65536").End(xlUp).Row
    Range(Cells(2, 1), Cells(Endline, 6)).Select
    Selection.Delete Shift:=xlUp 'ToLeft
    Range("A1").Activate
    ListFilesInFolder "c:\Digitsol\" & Jours, True
 
'Mettre validation de données
For n = 2 To Range("A65536").End(xlUp).Row
 Range("A" & n).Activate
 'Insertion liste OK/NOK
 ActiveCell.Offset(0, 3).Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=Check_Monday!$XFD$1:$XFD$2"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    'Insertion liste Block/
     ActiveCell.Offset(0, 2).Select
        With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=Check_Monday!$XFC$1:$XFC$2"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
        End With
 Next n
 
'Mise en place des stat
 
    Range("j1").Formula = "=COUNTIF(D2:D" & Endline & ","""")/" & (Endline - 1)
    Range("j2").Formula = "=(" & Endline - 1 & "-COUNTBLANK(D2:D" & Endline & "))/" & (Endline - 1)
    Range("j3").Formula = "=COUNTIF(D2:D" & Endline & ",""OK"")/(" & (Endline - 1) & "-COUNTBLANK(D2:D" & Endline & "))"
    Range("j4").Formula = "=COUNTIF(D2:D" & Endline & ",""NOK"")/(" & (Endline - 1) & "-COUNTBLANK(D2:D" & Endline & "))"
    Range("j5").Formula = "=COUNTIF(F2:F" & Endline & ",""Block"")/(" & (Endline - 1) & "-COUNTBLANK(D2:D" & Endline & "))"
 
Range("A2").Activate
 
End Sub

Afin de ne pas réinventer ce qui existe déjà, je fais appel à vous. Dans ce répertoire, il arrive que l'on ajoute des fichiers PDF depuis ma dernière liste. Avez-vous déjà vu un bout de code qui permettrait de simplement (évidemment ) prendre ceux qui n'ont pas déjà été listés précédemment.

[kiki29]

Salut, cela ne répondra pas directement à ta question, mais regarde ici

Remarque subsidiaire : déjà tu mélanges Early Binding / Late Binding : voir ici

[Nico Chg]

Bonjour,

Voici une fonction que j'ai récupérer quelque part sur Internet (je ne saurais dire), et qui vérifie la présence d'un fichier (nom + extension).
Tu peux alors boucler sur les noms, et en vérifier l'existence, avant de les lister ?

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
Function ExistingFile(FileName As String)
 
On Error GoTo err
Dim oFSO As Scripting.FileSystemObject
Dim Str_Path as string
 
Str_Path = "Path/Path/Path"
'A changer, bien évidemment !
 
'Instanciation du FSO
Set oFSO = New Scripting.FileSystemObject
'Instanciation de l'objet File
If oFSO.FileExists(Path & FileName) Then
    ExistingFile = True
Else
    ExistingFile = False
End If
 
fin:
    Exit Function
 
err:
        Select Case err.Number
            Case 53: MsgBox "Le fichier est introuvable"
            Case Else: MsgBox "Erreur inconnue"
        End Select
 
Resume fin
 
End Function