Création répertoire en fonction date du document

Bonjour à tous,

Cela fait plusieurs jours que je cherche sur internet après ce problème mais je ne trouve pas mis à part qu'il faut que j'utilise la fonction MkDir.

J'ai déjà créé un code pour mon fichier mais en plus de ça, je veux que si les répertoires (et sous-répertoires) n'existent pas ils soient créés.

Je m'explique :

- pour le moment le nom du document créé est en fonction de la date mais en plus de ça j'ai envie de classer par mois et par année donc créé un répertoire année + un sous-répertoire mois (si ils n'existent pas) en fonction de la date de création du document (ou de son nom car le nom est en fonction de la création du document).

Public Sub Enregistrer() 'copie sauvegarde classeur
Dim nom As String
    nom = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & "_" & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hhmm") & ".xls"
    For n = ActiveSheet.Shapes.Count To 1 Step -1
    If Left(ActiveSheet.Shapes(n).Name, 6) = "Button" Then ActiveSheet.Shapes(n).Delete
  Next n 'Supression du bouton sur la copie
    ActiveWorkbook.SaveCopyAs "D:\Users\FX5180\Desktop\Test\Meyrin" & "\" & nom
    rep = MsgBox("Votre fichier est sauvegardé sous le nom : " & nom, vbYes + vbInformation, "Copie sauvegarde classeur")
    Workbooks.Open Filename:="D:\Users\FX5180\Desktop\Test\Meyrin" & "\" & nom 'Ouverture de la copie
    ThisWorkbook.Close SaveChanges:=False 'Fermeture de l'original
End Sub

Je travaille sous Excel 2010 et je suis débutant en VBA donc si vous avez d'autres solutions pour mon code déjà existant je suis preneur.

Merci d'avance pour le temps que vous consacrerez.

Bonjour Julien, bonjour le forum,

Peut-être comme ça :

Public Sub Enregistrer() 'copie sauvegarde classeur
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim A As String 'déclare la variable A (Année)
Dim M As String 'déclare la variable M (Mois)
Dim NCH As String 'déclare la variable NCH ( Nouveau CHemin d'accès)
Dim nom As String

CH = "D:\Users\FX5180\Desktop\Test\Meyrin\" 'définit le chemin d'accès CH
A = CStr(Year(Date)) 'définit l'année A
M = CStr(Format(Date, "mmmm")) 'définit le mois M
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
ChDir CH & A 'change le dossier courant (génère une erreur si ce dossier n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'efface l'erreur
    MkDir CH & A 'crée un nouveau dossier avec l'année en cours
End If 'fin de la condition
ChDir CH & A 'change le dossier courant
ChDir CH & A & "\" & M 'change le dossier courant (génère une erreur si ce dossier n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'efface l'erreur
    MkDir CH & A & "\" & M 'crée un nouveau dossier avec le mois en cours
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
ChDir CH & A & "\" & M 'change le dossier courant
NCH = CH & A & "\" & M & "\" 'définit le nouveau chenim d'accès NCH

nom = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & "_" & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hhmm") & ".xls"
For n = ActiveSheet.Shapes.Count To 1 Step -1
    If Left(ActiveSheet.Shapes(n).Name, 6) = "Button" Then ActiveSheet.Shapes(n).Delete
Next n 'Supression du bouton sur la copie
ActiveWorkbook.SaveCopyAs NCH & nom
rep = MsgBox("Votre fichier est sauvegardé sous le nom : " & nom, vbYes + vbInformation, "Copie sauvegarde classeur")
Workbooks.Open Filename:=NCH & nom 'Ouverture de la copie
ThisWorkbook.Close SaveChanges:=False 'Fermeture de l'original
End Sub

Cela fonctionne parfaitement bien.

Je te remercie de ton aide .

Rechercher des sujets similaires à "creation repertoire fonction date document"