Lister des fichiers d'un repertoire dont le nom contient certains caracteres

PAT0051

XLDnaute Nouveau
Bonjour à tous,

Je souhaite lister le nom des fichiers contenu dans un répertoire.
Pour lister les nom, pas de problème pour la macro, mais je souhaiterai lister seulement les fichiers contenant certains caractères, commençant par A uniquement et terminant par XXX, par exemple (les nom a selectionner ayant tous 10 caractères ....
Ci-joint le code que j'utilise pour lister les noms de fichier

Code:
Sub ListeFichiers(Repertoire As String)

    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    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)
    '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
        i = i + 1
    Next FileItem
    
End Sub


Quelqu’un à déjà eu ce besoin.
 

Staple1600

XLDnaute Barbatruc
Re : Lister des fichiers d'un repertoire dont le nom contient certains caracteres

Bonjour à tous


A priori ainsi amendé, ton code semble faire l'affaire
Code:
Sub ListeFichiers(Repertoire As String)

    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    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)
    '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 FileItem.Name Like "A*XXX.???" Then 'ajout ici
        'Inscrit le nom du fichier dans la cellule
        Cells(i, 1) = FileItem.Name
        End If
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
           Address:=FileItem.ParentFolder & "\" & FileItem.Name
        i = i + 1
    Next FileItem
   
End Sub
 

PAT0051

XLDnaute Nouveau
Re : Lister des fichiers d'un repertoire dont le nom contient certains caracteres

Bonjour et merci de ton aide,

Je viens de tester la condition mais j'ai toujours les noms des autre fichier qui remontent mais la présentation est différente. les fichiers sur lesquels j'ai effectué le trie "TEST*.xls*" sont bien sélectionnés mais les autres fichiers du répertoire sont aussi présents.
Regarde la pièce jointe Capture-1.pdf
 

Staple1600

XLDnaute Barbatruc
Re : Lister des fichiers d'un repertoire dont le nom contient certains caracteres

Re

Donc pour être plus précis, voici une petite macro illustrative
(la fonction vient du fil de JPN que je salue au passage)
Code:
Function Teste(ATester As String, MonPattern As String, MonType As String) As Boolean
Dim Match, Matches
With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = MonPattern
    Set Matches = .Execute(ATester)
    If MonType = "Unique" Then
    ' Choix sur la fonction pour savoir si le résultat de Matches doit être unique
    If Matches.Count = 1 Then Teste = True Else Teste = False
    Else
    ' Sinon, si on accepte plusieurs occurences
    If Matches.Count >= 1 Then Teste = True Else Teste = False
    ' Renvoie Vrai si c'est le cas
    End If
End With
End Function
Code:
Sub aaa()
Dim NomFic$, NomFicX$
NomFic = "AtestesXXX.xlsx"
NomFicX = Split(NomFic, ".")(0)
MsgBox Teste(NomFicX, "^\A\w{6}\XXX$", "Unique"), vbInformation, NomFic
NomFic = "BtestesXXX.xlsx"
NomFicX = Split(NomFic, ".")(0)
MsgBox Teste(NomFicX, "^\A\w{6}\XXX$", "Unique"), vbCritical, NomFic
End Sub
Pour l’utiliser dans ton code, il faudrait écrire un truc du genre
Code vba:
'ici début de ton code initial
For Each FileItem In SourceFolder.Files
NomSansExt = Split(FileItem.Name, ".")(0)
If Teste(NomSansExt, "^\A\w{6}\XXX$", "Unique") Then
'Inscrit le nom du fichier dans la cellule
MsgBox FileItem.Name ' ici pour test
'ici fin de ton code initial




Je le laisse faire en faisant les modifs.

PS: J'ai testé avec ces noms de fichiers: A123456XXX.txt et AtestesXXX.txt
(la fonction renvoie VRAI avec ces deux noms qui matchent tes critères:
un nom de fichier de 10 caractères qui comme par A et fini par XXX
 

Docmarti

XLDnaute Occasionnel
Re : Lister des fichiers d'un repertoire dont le nom contient certains caracteres

Bonjour Pat0051; Staple1600; le Forum

Une variante avec Fso.GetExtensionName.


Code:
Sub ListeFichiers(Repertoire As String)

    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    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)
    '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
     strExtension = Fso.GetExtensionName(FileItem.Name)
     If Right(strExtension, 1) = "." Then strExtension = Mid(strExtension, 1, Len(strExtension) - 1)
     
     NomSansExtension = Mid(FileItem.Name, 1, Len(FileItem.Name) - Len(strExtension))
    
    If UCase(NomSansExtension) Like "A*" And Len(NomSansExtension) = 10 Then 'ajout ici
     
        '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
        i = i + 1
        End If
    Next FileItem
    
End Sub


Cordialement

Docmarti
 

PAT0051

XLDnaute Nouveau
Re : Lister des fichiers d'un repertoire dont le nom contient certains caracteres

Déjà, merci à tous deux de vous occuper de mon problème mais je n'ai que de notion de base en VBA et je bidouille les codes que je trouve en testant, retestant et rere....

Je viens de rentrer le code de Docmarti et cela fonctionne, je peux réaliser les tries que je souhaite :cool:
Par contre pour ton code, Staple1600, je pense avoir bien copié la fonction dans le module mais je dois avoir une erreur quelque part......la fonction Teste reste non indéfinie :confused:
Code:
Sub ListeFichiers(Repertoire As String)

    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
    Dim NomSansExt$
    
    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
        NomSansExt = Split(FileItem.Name, ".")(0)
            If Teste(NomSansExt, "^\A\w{6}\XXX$", "Unique") Then
            'Inscrit le nom du fichier dans la cellule
            MsgBox FileItem.Name ' ici pour test
            Cells(i, 1) = FileItem.Name
            End If
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
           Address:=FileItem.ParentFolder & "\" & FileItem.Name
        i = i + 1
    Next FileItem
   
End Sub
 

Staple1600

XLDnaute Barbatruc
Re : Lister des fichiers d'un repertoire dont le nom contient certains caracteres

Re


Normalement tu devrais avoir tout cela dans ton module
(Elle n'apparaissait dans le copier/coller de ton dernier message, donc je l'ai remis, voir ci-dessous)
Par contre pour ton code, Staple1600, je pense avoir bien copié la fonction dans le module mais je dois avoir une erreur quelque part......la fonction Teste reste non indéfinie :confused:
Code:
Sub ListeFichiers(Repertoire As String)

    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
    Dim NomSansExt$
    
    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
        NomSansExt = Split(FileItem.Name, ".")(0)
            If Teste(NomSansExt, "^\A\w{6}\XXX$", "Unique") Then
            'Inscrit le nom du fichier dans la cellule
            MsgBox FileItem.Name ' ici pour test
            Cells(i, 1) = FileItem.Name
            End If
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
           Address:=FileItem.ParentFolder & "\" & FileItem.Name
        i = i + 1
    Next FileItem
   
End Sub
'Je remets la fonction Teste
Code:
Function Teste(ATester As String, MonPattern As String, MonType As String) As Boolean
Dim Match, Matches
With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = MonPattern
    Set Matches = .Execute(ATester)
    If MonType = "Unique" Then
    ' Choix sur la fonction pour savoir si le résultat de Matches doit être unique
    If Matches.Count = 1 Then Teste = True Else Teste = False
    Else
    ' Sinon, si on accepte plusieurs occurences
    If Matches.Count >= 1 Then Teste = True Else Teste = False
    ' Renvoie Vrai si c'est le cas
    End If
End With
End Function
 

PAT0051

XLDnaute Nouveau
Re : Lister des fichiers d'un repertoire dont le nom contient certains caracteres

Et de 3 solutions qui fonctionnent....cela 15 jours que je butais sur ce problème...
Le choix va être dur, je vais y réfléchir en faisant une petite pose ......et des crêpes.

Merci à tous
 

Discussions similaires

Réponses
19
Affichages
2 K

Statistiques des forums

Discussions
311 720
Messages
2 081 915
Membres
101 837
dernier inscrit
Ugo