XL 2019 Copie feuille active dans répertoire avec nom fichier dynamique

Bonjour Guiyom, bonjour le forum,

Peut-être comme ça :

VB:

Sub RAZ()
Dim jour As String, mois As String, annee As String
Dim NomFichier As String 'déclare la variable NomFichier
Dim F As String 'déclare la variable F (Fichier)
Dim PCN As String 'déclare la variable PCN (Premières Caractères du Nom))
Dim DN As Integer 'déclare la variable DN (Dernier Numéro)
Dim DNM As Integer 'déclare la variable DNM (Dernier Numéro Max)

jour = Cells(1, 1).Value
mois = Cells(1, 2).Value
annee = Cells(1, 3).Value
NomFichier = "test du " & jour & "." & mois & "." & annee 'définit le nom du fichier NomFichier en fonction de la date
F = Dir("C:\Users\PC\Desktop\Nouveau dossier (4)\*.xlsm") 'définit le premier fichier xlsm du dossier spécifié
Do While F <> "" 'exécutre tant qu'il existe des fichiers F
    If InStr(1, F, NomFichier) <> 0 Then 'condition 1 : si le texte de NomFichier est contenu dans le texte de F
        If UBound(Split(F, ")")) > 0 Then 'condition 2 : s'il existe dans F caractère ")"
            PCN = Split(F, ")")(0) 'récupère dans la variable PCN le texte avant ce caratère
            DN = CInt(Split(PCN, "(")(1)) + 1 'définit le dernier numéro DN (les caractères de PCN après "(" convertis en entier + 1)
            If DN > DNM Then DNM = DN 'si DN est supérieure à DNM alors DBM devient DN (permet d'obtenir le numéro maximum)
        Else 'sinon (condition 1)
            DNM = 0 'définit DNM
        End If 'fin de la condition 2
    End If 'fin de la condition 1
    F = Dir 'définit le prochain fichier xlsm du dossier spécifié plus haut
Loop 'boucle
Sheets("Feuil1").Copy 'extrait l'onglet Feuil1 conne un nouveau fichier
Sheets("Feuil1").Name = NomFichier & " (" & DNM & ")" 'renomme l'onglet
'suvre le fichier avec NomFichier suivi de " (DNM).XLSM" (par exemple test du 01.11.2019 (0).xlsm
ActiveWorkbook.SaveAs Filename:="C:\Users\PC\Desktop\Nouveau dossier (4)\" & NomFichier & " (" & DNM & ").xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close
End Sub

Robert à dit:

Bonjour Guiyom, bonjour le forum,

Peut-être comme ça :

VB:

Sub RAZ()
Dim jour As String, mois As String, annee As String
Dim NomFichier As String 'déclare la variable NomFichier
Dim F As String 'déclare la variable F (Fichier)
Dim PCN As String 'déclare la variable PCN (Premières Caractères du Nom))
Dim DN As Integer 'déclare la variable DN (Dernier Numéro)
Dim DNM As Integer 'déclare la variable DNM (Dernier Numéro Max)

jour = Cells(1, 1).Value
mois = Cells(1, 2).Value
annee = Cells(1, 3).Value
NomFichier = "test du " & jour & "." & mois & "." & annee 'définit le nom du fichier NomFichier en fonction de la date
F = Dir("C:\Users\PC\Desktop\Nouveau dossier (4)\*.xlsm") 'définit le premier fichier xlsm du dossier spécifié
Do While F <> "" 'exécutre tant qu'il existe des fichiers F
    If InStr(1, F, NomFichier) <> 0 Then 'condition 1 : si le texte de NomFichier est contenu dans le texte de F
        If UBound(Split(F, ")")) > 0 Then 'condition 2 : s'il existe dans F caractère ")"
            PCN = Split(F, ")")(0) 'récupère dans la variable PCN le texte avant ce caratère
            DN = CInt(Split(PCN, "(")(1)) + 1 'définit le dernier numéro DN (les caractères de PCN après "(" convertis en entier + 1)
            If DN > DNM Then DNM = DN 'si DN est supérieure à DNM alors DBM devient DN (permet d'obtenir le numéro maximum)
        Else 'sinon (condition 1)
            DNM = 0 'définit DNM
        End If 'fin de la condition 2
    End If 'fin de la condition 1
    F = Dir 'définit le prochain fichier xlsm du dossier spécifié plus haut
Loop 'boucle
Sheets("Feuil1").Copy 'extrait l'onglet Feuil1 conne un nouveau fichier
Sheets("Feuil1").Name = NomFichier & " (" & DNM & ")" 'renomme l'onglet
'suvre le fichier avec NomFichier suivi de " (DNM).XLSM" (par exemple test du 01.11.2019 (0).xlsm
ActiveWorkbook.SaveAs Filename:="C:\Users\PC\Desktop\Nouveau dossier (4)\" & NomFichier & " (" & DNM & ").xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close
End Sub

Cliquez pour agrandir...

Incroyable, c'est exactement le résultat que je cherchais et plus important encore il y à toute les explications nécessaire à la compréhension du code.

Merci pour la rapidité de réponse ainsi que le temps consacré à mon problème.

Bonjour,

Je sollicite à nouveau votre aide pour un détail qui m'intrigue.
J'ai modifier légèrement votre code afin qu'il puisse sauvegarder la feuille active en fonction de la date du jour dans un répertoire défini par l'année suivi d'un sous répertoire défini par le mois.
Il me créer donc pour la journée du 04/11/2019 :

c:\Desktop\Nouveau dossier (4)\2019\11\test du 4.11.2019 (0).xlsm

Cependant je souhaite savoir si il est possible de lui faire créer :

c:\Desktop\Nouveau dossier (4)\2019\Novembre\test du 4.11.2019 (0).xlsm

Vous trouverez en PJ le fichier.

Cordialement


PS : Je viens de me rendre compte que mes modifications entre en conflit avec l'idée de départ et écrase le fichier du jour précédent.

Bonsoir le fil

Une autre version de la macro RAZ

Staple1600 à dit:

Bonsoir le fil

Une autre version de la macro RAZ

VB:

Sub RAZ_ter()
Dim vDate, strPath As String, cpt&
vDate = Date: strPath = ThisWorkbook.Path & "\"
On Error Resume Next
cpt = Evaluate("Compteur")
On Error GoTo 0
cpt = cpt + 1
ThisWorkbook.Names.Add Name:="Compteur", RefersTo:=cpt
Application.DisplayAlerts = False
Sheets("Feuil1").Copy
  With ActiveWorkbook
    .Sheets(1).Name = Format(vDate, """test""ddmmyyyy")
    .SaveAs strPath & Format(vDate, """test du ""ddmmyyyy_") & cpt & ".xlsm", FileFormat:=52
    .Close True
  End With
Application.DisplayAlerts = True
ThisWorkbook.Save
End Sub

Cliquez pour agrandir...

Bonsoir,
Merci pour cette nouvelle méthode.
De mon coté j'ai réussi à corriger les 2 problèmes rencontré dans mon précédent post.

Une erreur de syntaxe sur un " \ " concernant l'écrasement du précédent fichier et l'utilisation de la fonction MonthName(Month()) pour obtenir le mois en lettre.

Je poste au cas ou le fichier corrigé.

Cordialement