Macro de backup

Version imprimable

Macro de backup

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:

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:

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?

23/03/2018, 12h15
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:

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:

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

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

Hello
Compris

Avec cela ca marche !
Merci

Code:

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

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:

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:

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:

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