Enregistrer classeur avec macro avec nom cellule et répertoire mensuel

Bonjour à tous,

je souhaite modifier une Macro de Grisan29, trouvé sur le Forum, afin de pouvoir enregistrer mon classeur contenant des macros avec le nom d'une cellule dans un répertoire Mensuel.

Le code de Grisan29, enregistre la Feuille 1 d'un classeur au format PDF , mais je suis incapable de l'adapter à ma situation.

Fichier au format EXCEL avec Macro . xlsm

Mon chemin : C:\Users\didie\Documents\

Répertoire : Création par le code VBA avec le nom du Mois et de l'Année

Le nom donné au classeur après lancement de la macro : correspond à la valeur de la Cellule (F1) de la Feuille (INTERVENTIONS)

Et si c'est possible, Fermer le classeur d'origine et garder ouvert le nouveau classeur enregistré.

Je suis novice en VBA et je vous sollicite afin de me venir en aide pour ce problème d'adaptation.

Merci par avance.

JP

Le code de Grisan29

Private Sub CommandButton1_Click()
  Application.DisplayAlerts = False
  Dim Chemin As String, Fichier As String, Rep As String
  Chemin = "C:\Users\vous-même\Desktop\Nouveau dossier\"
 'Chemin = ThisWorkbook.Path & "\"
 'créer un dossier avec le nom du mois et l'année en cours
 'si le mois change un autre dossier est créer
  Rep = Application.Proper(MonthName(Month(Date))) & " " & Year(Date)
  'gestion des erreurs
  On Error Resume Next
  'définition du chemin
  MkDir Chemin & Rep
  On Error GoTo 0
  Chemin = Chemin & Rep & "\"
  Sheets("Feuil1").Copy
  'copie de la feuille en ajoutant F devant le n° qui est en "C4" et +la date
  Fichier = Sheets("Feuil1").Range("C4") & " " & "F" & Format(Date, "ddmmyyyy") & ".Pdf"
  With ActiveWorkbook
  'code qui enregistre en .pdf
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & Fichier, Quality:=xlQualityStandard, _
                          IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                          From:=1, To:=1, OpenAfterPublish:=False
    'ferme le classeur créer
   .Close savechanges:=False
   'retabli les arlertes windows
    Application.DisplayAlerts = True
    'message pour dire que le fichier a bien été enregistrer
    'que le chemin est bon
    MsgBox ("Enregistré dans le dossier -Factures-")
  End With
End Sub

Hello

Tu peux tester ce code :

Private Sub CommandButton1_Click()
  Application.DisplayAlerts = False
  Dim Chemin As String, Fichier As String, Rep As String
  Chemin = "C:\Users\didie\Documents\"
  Rep = Application.Proper(MonthName(Month(Date))) & " " & Year(Date)
  On Error Resume Next
  MkDir Chemin & Rep
  On Error GoTo 0
  Chemin = Chemin & Rep & "\"
   ThisWorkbook.SaveAs Chemin & Sheets("INTERVENTIONS").Range("F1").Value & ".xslm"
    Application.DisplayAlerts = True
    MsgBox ("Enregistré ")
  End With
End Sub

R@g

Bonjour et Merci Rag02700 pour cette proposition,

Peux tu me préciser si le code est a placer dans un Module ou dans la feuille.

Je n'ai par encore bien compris la nuance de l'affectation d'un code d'une ou l'autre possibilité ?

J'ai supprimé le End With de trop et l'extension déjà ajouté en cellule F1.

Je joins mon fichier car je n'arrive pas à l'ajouter à ma petite image (disquette).

Merci encore de ton aide car la je pige pas pourquoi je n'arrive pas à l'ajouter à mon image.

Bonjour Rag02700 ,

j'ai trouvé grâce à toi la solution après quelques modifications dans le code ; suppression du End With en trop, l'extension erronée xslm déjà présente dans la Cellule F1 et j'ai modifié le Private Sub en Sub qui bloquait l'attribution de la macro à mon image.

Je ne devais pas être bien réveillé .... pour ne pas l'avoir vu avant.

Ca fonctionne parfaitement !

Je n'ai pas réussi à supprimer mon précèdent message donc je met en RESOLU.

Merci encore Rag02700 de ton aide.

Sub Enregistrement_Repertoire_Mensuel()
  Application.DisplayAlerts = False
  Dim Chemin As String, Fichier As String, Rep As String
  Chemin = "C:\Users\didie\Documents\"
  Rep = Application.Proper(MonthName(Month(Date))) & " " & Year(Date)
  On Error Resume Next
  MkDir Chemin & Rep
  On Error GoTo 0
  Chemin = Chemin & Rep & "\"
   ThisWorkbook.SaveAs Chemin & Sheets("INTERVENTIONS").Range("F1").Value
    Application.DisplayAlerts = True
    MsgBox ("Fichier Enregistré dans le Répertoire Mensuel")
End Sub