[Résolu]reconnaitre la structure d'un nom de fichier

[francedemo]

bonjour à tous
j'utilise un bout de code (récupéré sur le site, qui me permet de lister tous les fichier d'un répertoire, je l'ai modifié pour coller à mon besoin en terme de cellule à recopier.

par contre là je bute sur la reconnaissance sur le nom de fichier => dans ce répertoire, j'ai tous les fichiers que je veux lister et certains autres que je veux ignorer, tous les fichiers à lister sont sur la même structure au niveau du nom de fichier, à savoir :
"nom du client" & "_" & "date d'édition de la fiche" & ".xls"
le nom du client, c'est forcément n'importe quoi (les espaces sont remplacé par "_", quand même)
et la date,sous la forme "yyyy_mm_jj_" pour des questions de tri, elle est variable aussi (bin oui, je travaille presque tous les jours, donc la date change...)

dans le code j'utilise déjà :

Do While Fichier <> ""

pour ne traiter que les fichiers existants

il faudrait que j'ajoute

et "nom fichier" termine par une date quelconque sous la forme "yyy_mm_jj_"

si quelqu'un pouvait m'orienter sur le code

merci d'avance

juste pour info, je vous mets le code complet ci dessous:

Sub ListeFichiersContenu()
'macro

Dim Fichier As String
Dim FichierBase As String
Dim FichierNom As String
Dim Chemin As String
Dim DerLigne As Long
Dim DerLigneA As Long
Dim FeuilleBase As Excel.Worksheet

debut = Timer

FichierBase = ThisWorkbook.Name
Set FeuilleBase = ThisWorkbook.Sheets("Base")

'===Nettoyer la zone et sélectionner la cellule de début
FeuilleBase.Range("A1").CurrentRegion.Offset(1, 0).Clear

'===Saisir le chemin complet du dossier où se trouvent les fichiers
Chemin = ThisWorkbook.Path & "\"

'===Valider le premier fichier
Fichier = Dir(Chemin & "*.xls")
Do While Fichier <> ""
'===Désactiver les affichages et les macros
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
'===Valider les variables
    DerLigne = FeuilleBase.Range("E65536").End(xlUp).Row + 1
'===Interdire le traitement du fichier en cours
    If Fichier <> FichierBase Then
        Workbooks.Open Filename:=Chemin & Fichier
        FichierNom = Left(Fichier, Len(Fichier) - 5)

'===Inserer un lien hypertexte "Lien Fichier" + Copier "Livraison"
        FeuilleBase.Hyperlinks.Add _
            FeuilleBase.Range("A" & DerLigne), Chemin & Fichier, , , FichierNom
        FeuilleBase.Range("B" & DerLigne).Value = _
            Workbooks(Fichier).Sheets("Base").Range("G6").Value
'===Copier "Facturation"
        FeuilleBase.Range("C" & DerLigne).Value = _
            Workbooks(Fichier).Sheets("Base").Range("Q6").Value
'===Copier "Matériel"
        FeuilleBase.Range("D" & DerLigne).Value = _
            Workbooks(Fichier).Sheets("Base").Range("H3").Value
'===Copier "Nb" + "Désignation"
        FeuilleBase.Range("E" & DerLigne & ":F" & DerLigne + 10).Value = _
            Workbooks(Fichier).Sheets("Base").Range("A13:B23").Value

'Remplissage des cellules vides de "Lien Fichier"
'            DerLigneA = Range("A65536").End(xlUp).Row
'            Derligne = Range("F65536").End(xlUp).Row
'            If DerLigneA < Derligne Then
'                Range("A" & DerLigneA, "A" & Derligne).FillDown
'            End If

'===Nettoyer les lignes vides (boucle sur la dernière insertion)
        FeuilleBase.Activate
'===Valider les variables
        DerLigneA = FeuilleBase.Range("F65536").End(xlUp).Row
        For n = DerLigneA + 1 To DerLigne Step -1
            If Range("E" & n) = "" Or Range("F" & n) = "Désignation*hors référence :" Then
                Rows(n).Delete
            End If
        Next n
'===Valider les variables
        DerLigne = FeuilleBase.Range("E65536").End(xlUp).Row
'===Inserer une ligne *Gras* + *Jaune* sous chaque bloc inséré
        With FeuilleBase.Range("A" & DerLigne, "F" & DerLigne).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 6
        End With
       
'===Fermer le fichier Devis ouvert
        Windows(Fichier).Activate
        Application.CutCopyMode = False
        ActiveWorkbook.Close savechanges:=False
'===Valider le fichier suivant
    End If
    Fichier = Dir
Loop
'===Valider la fin de la boucle

'==Mettre en forme les colonnes
FeuilleBase.Activate
Columns("A:A").ColumnWidth = 50
Columns("B:C").ColumnWidth = 40
Columns("D:D").ColumnWidth = 25
Columns("E:F").EntireColumn.AutoFit

'===Mettre en forme les cellules
With Selection.Font
    .Name = "Arial"
    .Size = 12
End With

'===Activer les affichages + macros
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.CutCopyMode = False

Range("A2").Activate

MsgBox ("Terminé en " & Timer - debut & " seconde(s)")

End Sub

 

[sousou]

Re : reconnaitre la structure d'un nom de fichier

Bonjour francedemo
Tu peux essayer d'intégrer ce test
fichier = ActiveCell.Value
x = Mid(fichier, Len(fichier) - 39, 10)
madate = Right(x, 2) & "/" & Mid(x, 6, 2) & "/" & Left(x, 4)
If IsDate(madate) = True Then MsgBox "Ok" Else MsgBox "Non"

 

[francedemo]

Re : reconnaitre la structure d'un nom de fichier

merci sousou

j'ai testé, avec quelques ajustement, ça fonctionne

j'ai modifié =

fichier = ActiveCell.Value
x = Mid(fichier, Len(fichier) - 39, 10)
madate = Right(x, 2) & "/" & Mid(x, 6, 2) & "/" & Left(x, 4)
If IsDate(madate) = True Then MsgBox "Ok" Else MsgBox "Non"

par =

'fichier = ActiveCell.Value => supprimé, j'ai déjà une définition de "fichier"
x = Mid(fichier, Len(fichier) - 15, 10) 'passé de 39 (?) à 15 pour n'avoir 
que les caractères de la date
madate = Right(x, 2) & "/" & Mid(x, 6, 2) & "/" & Left(x, 4)
If IsDate(madate) = True Then "mon code"
'MsgBox "Ok" Else MsgBox "Non" 'supprimé

j'ai testé et seuls les fichiers dont nom fini par "yyyy_mm_jj_.xls" sont traités, c'est exactement ce dont j'avais besoin

merci encore