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

guiyom

XLDnaute Junior
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é :

VB:
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

XLDnaute Barbatruc
Repose en paix
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
 

guiyom

XLDnaute Junior
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

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

XLDnaute Junior
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.
 

Pièces jointes

  • test.xlsm
    24.5 KB · Affichages: 5
Dernière édition:

Staple1600

XLDnaute Barbatruc
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
 

guiyom

XLDnaute Junior
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

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
 

Pièces jointes

  • test (2).xlsm
    28.7 KB · Affichages: 5

Discussions similaires

Statistiques des forums

Discussions
311 710
Messages
2 081 781
Membres
101 817
dernier inscrit
carvajal