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

[guiyom]

Bonjour,

Je sollicite votre aide afin de trouver une solution à mon problème certainement ridicule mais au dessus de mes capacités.

J'utilise une macro me permettant d'effectuer une copie de ma feuille active dans un répertoire défini avec un nom déterminé par la date du jour.
Le problème étant que j'utilise cette macro parfois plusieurs fois par jours et donc à chaque fois la précédente sauvegarde est écrasée par la nouvelle.

Je souhaiterai qu'un petit compteur à la fin du nom du fichier s'inscrive si j'utilise la macro plusieurs fois dans la même journée.

Exemple :
test du 01/11/2019
test du 01/11/2019(1)
test du 01/11/2019(2)

Voici le code utilisé :

Sub RAZ()
Dim jour As String, mois As String, annee As String


jour = Cells(1, 1).Value
mois = Cells(1, 2).Value
annee = Cells(1, 3).Value

    Sheets("Feuil1").Copy
    Sheets("Feuil1").Name = "test" & jour & mois & annee
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="C:\Users\PC\Desktop\Nouveau dossier (4)" + "\test du " & jour & "." & mois & "." & annee & ".xlsm", _
    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Application.DisplayAlerts = True
    ActiveWorkbook.Close

End Sub

Cordialement

 

[Robert]

Bonjour Guiyom, bonjour le forum,

Peut-être comme ça :

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

 

[guiyom]

Bonjour Guiyom, bonjour le forum,

Peut-être comme ça :

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

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.

 

[guiyom]

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.

 

[Staple1600]

Bonsoir le fil

Une autre version de la macro RAZ

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

 

[guiyom]

Bonsoir le fil

Une autre version de la macro RAZ

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

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