Discussion :

[GADENSEB]

Bonjour Le forum,
J'ai cette macro de fichier qui fonctionne au poil.
L'arborescence est du Typer "00 - BACKUP\2018\03 - MARS\2018.03.23"

Cela bug "Seulement"si l'année (2018) ou le mois (03 - MARS) n'existe pas.... je pige pas
j'ai pourtant mis un

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
  'Si le dossier 00 - BACKUP n'éxiste pas alors je le créer
  If Dir(Répertoire, vbDirectory) = "" Then MkDir (Répertoire)

Est-ce qu'il faut que je fasse le test sur le mois puis sur l'année ??

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

Sub Sauvegarde_Journaliere()
  Dim Répertoire As String, NomFichier As String, AnneeDossier As String, MoisDossier As String, JourDossier As String
  AnneeDossier = Year(Date)
  MoisDossier = Format(Month(Date), "00") & " - " & UCase(sansAccent(Format(Date, "MMMM")))
  JourDossier = Format(Date, "yyyy.mm.dd")

  Répertoire = ActiveWorkbook.Path & "\00 - BACKUP" & "\" & AnneeDossier & "\" & MoisDossier & "\" & JourDossier


  'Si le dossier 00 - BACKUP n'éxiste pas alors je le créer
  If Dir(Répertoire, vbDirectory) = "" Then MkDir (Répertoire)


  ' Créer un nom de fichier unique par jour
  NomFichier = ThisWorkbook.Name
  NomFichier = Left(NomFichier, Len(NomFichier) - 5)
' NomFichier = NomFichier & "-" & Format(Date, "dd.mm.yyyy") & ".xlsm"
  NomFichier = NomFichier & "-" & Format(Date, "yyyy.mm.dd") & ".xlsm"
  ' Vérifier si le fichier du jour n'existe pas
  If Dir(Répertoire & "\" & NomFichier) = "" Then
    'Sauvegarde une copie du fichier et ne touche donc pas au fichier en cours
    ActiveWorkbook.SaveCopyAs Filename:=Répertoire & "\" & NomFichier
  End If
End Sub

QQn aurait une idée?

[unparia]

Bonjour
Question déjà traitée de manière récurrente sur ce forum
- soit tu utilises MKDir pour traiter (ajouter si non existant ou non si déjà existant) chaque chemin du chemin complet
- soit tu utilises la fonction SHCreateDirectoryEx de la librairie shell32 de l'Api de Windows qui, elle, est capable de tout faire à ta place (ne créer que ce qu'il est nécessaire de créer).

Ainsi :
dans la partie déclarative du module de code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

et cela en appel de cette fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

SHCreateDirectoryEx 0, "c:\titi\toto\tata\", ByVal 0&

créera tous les sous-dossiers nécessaires non déjà existants

[GADENSEB]

Hello
Compris

Avec cela ca marche !
Merci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub Sauvegarde_Journaliere()  Dim Répertoire As String, NomFichier As String, AnneeDossier As String, MoisDossier As String, JourDossier As String
  AnneeDossier = Year(Date)
  MoisDossier = Format(Month(Date), "00") & " - " & UCase(sansAccent(Format(Date, "MMMM")))
  JourDossier = Format(Date, "yyyy.mm.dd")
 
 ' Répertoire = ActiveWorkbook.Path & "\00 - BACKUP" & "\" & AnneeDossier & "\" & MoisDossier & "\" & JourDossier
  Répertoire = ActiveWorkbook.Path & "\00 - BACKUP" & "\" & AnneeDossier
 
  'Si le dossier 00 - BACKUP n'éxiste pas alors je le créer
  If Dir(Répertoire, vbDirectory) = "" Then MkDir (Répertoire)
 
  Répertoire = ActiveWorkbook.Path & "\00 - BACKUP" & "\" & AnneeDossier & "\" & MoisDossier
    'Si le dossier 00 - BACKUP n'éxiste pas alors je le créer
  If Dir(Répertoire, vbDirectory) = "" Then MkDir (Répertoire)
 
 
  Répertoire = ActiveWorkbook.Path & "\00 - BACKUP" & "\" & AnneeDossier & "\" & MoisDossier & "\" & JourDossier
   'Si le dossier 00 - BACKUP n'éxiste pas alors je le créer
  If Dir(Répertoire, vbDirectory) = "" Then MkDir (Répertoire)
 
 
 
 
 
 
  ' Créer un nom de fichier unique par jour
  NomFichier = ThisWorkbook.Name
  NomFichier = Left(NomFichier, Len(NomFichier) - 5)
 ' NomFichier = NomFichier & "-" & Format(Date, "dd.mm.yyyy") & ".xlsm"
  NomFichier = NomFichier & "-" & Format(Date, "yyyy.mm.dd") & ".xlsm"
  ' Vérifier si le fichier du jour n'existe pas
  If Dir(Répertoire & "\" & NomFichier) = "" Then
    'Sauvegarde une copie du fichier et ne touche donc pas au fichier en cours
    ActiveWorkbook.SaveCopyAs Filename:=Répertoire & "\" & NomFichier
  End If
End Sub

Merci à toi

[patricktoulon]

bonjour GADENSEB

juste un petit exemple
la fonction "Create_dossier" peut etre réutilisée a souhait :il suffit de lui injecter le chemin complet j'usquau dernier dossier fils comme dans ton exemple
elle se chargera de créer les dossiers intermediaires (parent) si ils existent pas

la sub pour tester

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub test()
    Dim AnneeDossier As Long, MoisDossier As Variant, repertoire As String
    AnneeDossier = Year(Date)
    MoisDossier = moisUSansAccent(Date)
    JourDossier = Format(Date, "yyyy.mm.dd")
    repertoire = ActiveWorkbook.Path & "\00 - BACKUP" & "\" & AnneeDossier & "\" & MoisDossier & "\" & JourDossier
    Create_dossier repertoire
End Sub

la fonction de creation de dossier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Function Create_dossier(chemin)
    Dim herarchie, I As Long, x As String
    herarchie = Split(chemin, "\")
    For I = 0 To UBound(herarchie)
        On Error Resume Next
        x = x & herarchie(I) & "\": If Dir(x, vbDirectory) = "" Then MkDir x
    Next
End Function

la fonction mois sans accent

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Function moisUSansAccent(ladate) As String
moisUSansAccent = UCase(Replace(Replace(Format(ladate, "mmmm"), "é", "e"), "û", "u"))
End Function