XL 2016 fichier le plus récent dans le répertoire Téléchargements

[ivan27]

Bonjour le forum

Je souhaite améliorer ma procédure ci-dessous pour qu'elle s'applique non pas sur le fichier1.xml de mon bureau mais sur le fichier le plus récent de mon répertoire ''Téléchargement'' ayant la structure suivante :

xxxxxx20180222.045634564.xml

xxxxxx = nom client (longueur variable)
20180222 = date. ici le 22 février 2018
045634564 = numéro de fichier sur 9 caractères (plus le fichier est récent, plus ce numéro est élevé)

Donc, si dans mon répertoire Téléchargements j'ai plusieurs fichiers dont :

xxxxxx20180101.027600976.xml
aaaaaaaa20170225.045634564.xml
abcdef20180328.000981260.xml
bcdef20180328.000981254.xml
bbb20180222.045634564.xml

ma procédure doit s'appliquer sur le fichier abcdef20180328.000981260.xml

Merci d'avance pour vos propositions.

Sub SupprimerCaracteres()
Dim nf As String

nf = CreateObject("WScript.Shell").specialFolders("Desktop")

 Open nf & "\fichier1.xml" For Input As #1
 Open nf & "\fichier2.xml" For Output As #2
 Do While Not EOF(1)
    c = Input(1, #1)
   If c = "<" Then Bypasser = True
   If c = ">" Then Bypasser = False
   If Bypasser = False Then
       If c = "@" Then: c = " "
       If c = "ß" Then: c = "B"
       If c = "ä" Then: c = "a"
       If c = "ï" Then: c = "i"
       If c = "ö" Then: c = "o"
       If c = "ü" Then: c = "u"
       If c = "Ä" Then: c = "A"
       If c = "Ï" Then: c = "I"
       If c = "Ö" Then: c = "O"
       If c = "Ü" Then: c = "U"
       If c = "©" Then: c = " "
       If c = "'" Then: c = " "
       If c = "*" Then: c = " "
       If c = "²" Then: c = " "
       If c = "&" Then: c = " "
       If c = "~" Then: c = " "
       If c = "#" Then: c = " "
       If c = "{" Then: c = " "
       If c = "[" Then: c = " "
       If c = "|" Then: c = " "
       If c = "`" Then: c = " "
       If c = "\" Then: c = " "
       If c = "^" Then: c = " "
       If c = "]" Then: c = " "
       If c = "}" Then: c = " "
       If c = "+" Then: c = " "
       If c = "$" Then: c = " "
       If c = "£" Then: c = " "
       If c = "¤" Then: c = " "
       If c = "µ" Then: c = " "
       If c = "§" Then: c = " "
        Debug.Print c
   End If
   Print #2, c;
 Loop
 Close #1, #2
End Sub

 

[Theze]

Bonjour,

Une piste pour la récup du fichier le plus récent. Il est indispensable que que le dossier ne contienne que des fichiers ayants le même montage du nom :

Sub Test()

    Dim Dico As Object
    Dim Cle As Variant
    Dim Tbl() As String
    Dim Tablo(1 To 2)
    Dim T
    Dim Max As Long
    Dim I As Integer
    Dim Fichier As String
    Dim Chemin As String
   
    'adapter le chemin du dossier !!!!
    Chemin = "C:\Users\Ton nom d'utilisateur\Downloads\"
   
    Tbl() = RecupFichiers(Chemin, "xml")
   
    If Not Not Tbl Then
       
        Set Dico = CreateObject("Scripting.Dictionary")
       
        For I = 1 To UBound(Tbl)
       
            T = Split(Tbl(I), ".")
           
            If Not Dico.exists(Right(T(0), 8)) Then
           
                Tablo(1) = T(1): Tablo(2) = Tbl(I)
                Dico.Add Right(T(0), 8), Tablo()
               
            Else
           
                If T(1) > Dico(Right(T(0), 8))(1) Then
               
                    Dico(Right(T(0), 8))(1) = T(1)
                    Dico(Right(T(0), 8))(2) = Tbl(I)
                   
                End If
           
            End If
           
        Next I
       
        For Each Cle In Dico.Keys
           
            If Cle > Max Then: Max = Cle: Fichier = Dico(Cle)(2)
           
        Next Cle
       
        MsgBox "Le fichier le plus récent est : " & Fichier
   
    End If
   
End Sub

Function RecupFichiers(Chemin As String, Extension As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
   
    If Left(Extension, 1) <> "." Then Extension = "." & Extension
   
    Fichier = Dir(Chemin & "*" & "*" & Extension)
   
    Do While (Len(Fichier) > 0)
   
        I = I + 1
       
        ReDim Preserve TableauFichiers(1 To I)
       
        TableauFichiers(I) = Fichier
       
        Fichier = Dir()
       
    Loop
   
    RecupFichiers = TableauFichiers()

End Function

 

[ivan27]

Rebonjour le forum, Theze,

Merci beaucoup pour ta proposition et le temps passé à répondre à mon besoin.
Je viens cependant de me rendre compte, pendant les tests, d'un problème que je n'avais pas identifié et je ne vais pas pouvoir utiliser ton code en l'état. Je suis désolé...
En effet, quand j'importe un .xml depuis mon logiciel métier, le nom du fichier téléchargé porte la date de commande mais pas la date de l'opération d'import.
Idéalement, il faudrait pouvoir identifier le dernier fichier déposer dans le répertoire.
Ivan

 

[Theze]

Bonjour,

Alors, testes cette méthode, lances la procédure "DernierFichier" en ayant au préalable adapté le chemin du dossier :

Sub DernierFichier()
   
    Dim Tbl() As String
    Dim Chemin As String
    Dim DateMax As Date
    Dim Fichier As String
    Dim I As Integer
   
    Chemin = "C:\Users\Ton nom d'utilisateur\Downloads\"
   
    Tbl() = ListeFichiers(Chemin, ".xml")
   
    If Not Not Tbl Then
   
        For I = 1 To UBound(Tbl)
       
            If DateMax < ProprietesFichier(Chemin & Tbl(I)) Then
           
                DateMax = ProprietesFichier(Chemin & Tbl(I))
                Fichier = Tbl(I)
               
            End If
       
        Next I
       
        MsgBox Fichier & vbCrLf & DateMax
       
    End If
   
End Sub

Function ProprietesFichier(Chemin As String) As String

    Dim Fso As Object
    Dim Doc As Object
   
    If Dir(Chemin) <> "" Then
   
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set Doc = Fso.GetFile(Chemin)
       
        With Doc
            ProprietesFichier = .DateLastModified
        End With
       
    Else
       
        ProprietesFichier = "Fichier introuvable"
   
    End If
   
   
    Set Doc = Nothing
    Set Fso = Nothing

End Function

Function ListeFichiers(Chemin As String, _
                       Extension As String) As String()
  
    Dim Tbl() As String
    Dim Fichier As String
    Dim I As Integer
   
    Fichier = Dir(Chemin & "*" & Extension)
   
    Do While (Len(Fichier) > 0)
       
        If InStr(Fichier, Extension) <> 0 Then
           
            I = I + 1
            ReDim Preserve Tbl(1 To I)
            Tbl(I) = Fichier
           
        End If
       
        Fichier = Dir()
       
    Loop
  
    ListeFichiers = Tbl()
   
End Function