Compter fichier ayant la meme date de création dans un repertoire donné

[juju33]

Bonjour,

Je suis novice en VBA.
Dans un répertoire donné j'ai des fichiers du type xxxxxYYYxxxxxx et xxxxxZZZZxxxxx.
J'aimerai compter tous les fichiers contenant la chaine YYY et ZZZ dans leur nom et ayant la même date de création.
Pour finir j’aimerai afficher le résultat dans une feuille excel.
Je ne m'en sors pas...

Merci de votre aide.

 

[job75]

Re : Compter fichier ayant la meme date de création dans un repertoire donné

Bonsoir juju33, bienvenue sue XLD,

Je suis novice en VBA.
(...)
Je ne m'en sors pas...

Vous allez vous en sortir mais probablement sans comprendre grand-chose car c'est "un peu" compliqué...

Mettez le fichier joint dans le dossier de vos fichiers à traiter.

Ce code (Alt+F11) s'exécute en cliquant sur le bouton :

Option Compare Text 'facultatif, pour ignorer la casse

Sub RechercheFichiers()
Dim texte1$, texte2$, chemin$, fs, fichier$, n&, tablo(), t, i&, rest()
texte1 = "YYY" 'à adapter
texte2 = "ZZZ" 'à adapter
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
Set fs = CreateObject("Scripting.FileSystemObject")
'---recherche des fichiers---
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
While fichier <> ""
  If fichier Like "*" & texte1 & "*" Or fichier Like "*" & texte2 & "*" Then
    n = n + 1
    ReDim Preserve tablo(1 To 2, 1 To n)
    tablo(1, n) = fichier
    tablo(2, n) = Int(CDbl(CDate(fs.getfile(chemin & fichier).datecreated)))
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
'---restitution---
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).ClearContents 'RAZ
If n Then
  '---liste complète triée par dates---
  [A2].Resize(n, 2) = Application.Transpose(tablo) 'maximum 65536 lignes
  [A2].Resize(n, 2).Sort [B2], xlAscending, , [A2], xlAscending, Header:=xlNo
  '---doublons de dates---
  t = [A1].Resize(n + 2, 2)
  ReDim rest(1 To n, 1 To 2)
  For n = 2 To n + 1
    If t(n, 2) = t(n - 1, 2) Or t(n, 2) = t(n + 1, 2) Then
      i = i + 1
      rest(i, 1) = t(n, 1)
      rest(i, 2) = t(n, 2)
    End If
  Next
  If i Then [D2].Resize(i, 2) = rest
End If
Columns.AutoFit 'ajustement de la largeur des colonnes
Set fs = Nothing 'RAZ
End Sub

Nota 1 : s'il y a plus de 65536 fichiers qui répondent aux critères, dites-le, je modifierai.

Nota 2 : j'ai mis "000" devant le nom du fichier pour qu'il soit classé en tête du dossier.

Bonne fin de soirée.

A+

 

[job75]

Re : Compter fichier ayant la meme date de création dans un repertoire donné

Bonjour juju33, le forum,

Voici une solution un peu plus élaborée.

Le code est maintenant dans la feuille (clic droit sur l'onglet et Visualiser le code) :

Option Compare Text 'facultatif, pour ignorer la casse

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H1,J1]) Is Nothing Then Exit Sub
Dim texte1 As Range, texte2 As Range, chemin$, fichier$, fs As Object
Dim test1 As Boolean, test2 As Boolean, n&, tablo(), t, rest(), i&
Target.Select
Set texte1 = [H1]: Set texte2 = [J1]
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
'---recherche des fichiers---
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Set fs = CreateObject("Scripting.FileSystemObject")
While fichier <> ""
  test1 = IIf(texte1 = "", False, fichier Like "*" & texte1 & "*")
  test2 = IIf(texte2 = "", False, fichier Like "*" & texte2 & "*")
  If test1 Or test2 Then
    n = n + 1
    ReDim Preserve tablo(1 To 2, 1 To n)
    tablo(1, n) = fichier
    tablo(2, n) = CDbl(CDate(fs.getfile(chemin & fichier).datecreated))
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
Set fs = Nothing 'RAZ
'---restitution---
Application.ScreenUpdating = False
Range("A2:E" & Rows.Count).ClearContents 'RAZ
If n Then
  '---liste complète triée par dates/heures---
  [A2].Resize(n, 2) = Application.Transpose(tablo) 'maximum 65536 lignes
  [A2].Resize(n, 2).Sort [B2], xlAscending, Header:=xlNo
  '---doublons de dates---
  t = [A1].Resize(n + 2, 2)
  ReDim rest(1 To n, 1 To 2)
  For n = 2 To n + 1
    t(n, 2) = Int(t(n, 2))
    If t(n, 2) = t(n - 1, 2) Or t(n, 2) = Int(t(n + 1, 2)) Then
      i = i + 1
      rest(i, 1) = t(n, 1)
      rest(i, 2) = t(n, 2)
    End If
  Next
  If i Then [D2].Resize(i, 2) = rest
End If
'---largeurs des colonnes---
[A:B,D:E].ColumnWidth = 10.71
[A:E].Columns.AutoFit
Union(texte1, texte2).EntireColumn.AutoFit
If texte1.ColumnWidth < 10.71 Then texte1.ColumnWidth = 10.71
If texte2.ColumnWidth < 10.71 Then texte2.ColumnWidth = 10.71
End Sub

Fichier (2).

Bonne journée.

 

[job75]

Re : Compter fichier ayant la meme date de création dans un repertoire donné

Re,

Sur Win XP - Excel 2003, la durée d'exécution pour analyser et restituer 10000 fichiers est de 2,4 secondes.

A+