Sauvegarde Automatique dans un sous dossier

Le 28/08/2023 à 13:42

Bien le bonjour à tous, je suis à la recherche d'une aide, d'un conseille.

Je débute dans le VBA j'en fait pas souvent mais en se moment il m'arrive d'en faire.

Voilà ma problématique, j'ai un fichier que j'utilise assez fréquemment et j'aimerais gagner quelque clics pour le sauvegarder à un endroit à chaque fois se qui peut me faire un gain de temps quand j'ai 3 machines à faire.

J'aimerais que le VBA regarde si le fichier existe si ce n'est pas le cas il le crée pareille je voudrais qu'il regarde si le sous dossier exciste si non il crée et apres il s'enregistre.

Exemple : la case H13 et l'année renseigné dans le document le ficher sera 2023 (renseigné en H13) et le sous dossier sera le mois renseigné en G13.

Si dans C:2023 existe pas sa le crée automatiquement ensuite ca ira dans C:2023/Septembre si il existe pas ca le crée si sa existe j'enregistre le fichier dans C:2023/Septembre/01)Fichier.xmlx (le 01 sera le jours renseigné en F13)

Si une ame charitable peut m'aider s'il vous plait, et m'expliqué je vous remercie

Le 28/08/2023 à 14:25

Bonjour,

J'avais fait un petit truc pour une de mes collegues qui avait tendance a faire des boulettes avec son pricipal fichier de travail.

Donc cette macro qui s'execute a l'ouverture du fichier, on cree une sauvegarde dans le sous repertoire qui s'appelle SVG du fichier en question en gardant les differentes versions deja enregistrées.

Voila le code

Sub macro1()
Dim monrep As String
Dim fnom As String
Dim nom_fichier As String
monrep = "C:\Users\user\Desktop\dossier_pere\svg\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(monrep).Files

nom_fichier = Date & " _ " & Time
nom_fichier = Replace(nom_fichier, "/", "_")
nom_fichier = Replace(nom_fichier, ":", "-")
nom_fichier = objFiles.Count + 1 & "#" & nom_fichier

ActiveWorkbook.SaveCopyAs monrep & nom_fichier + ActiveWorkbook.Name

Set objFiles = Nothing
Set fso = Nothing

End Sub

Si classeur 1 est le document a sauvegarder, ca donne ca 12#28_08_2023 _ 14-20-56Classeur1

12 parcequ'il y avait deja 11 sauvegardes dans les dossier SVG

8_08_2023 _ 14-20-56 Date et heure de sauvegarde

Classeur1 c'et le nom du classeur

Peut etre une base pour debuter ton code

@ +

Le 28/08/2023 à 15:03

Bonjour,

En complément :

1test-kuma.xlsm (16.69 Ko)
Public Sub Vérif_Save()
Dim Emp_Dossier, Emp_SsDossier, Emp_Fichier As String

With ThisWorkbook.Worksheets(1) 'On considere le Feuil1 comme étant celle des donnees
    If .Range("H13") = "" Then 'Verif Dossier renseigné
        MsgBox ("Dossier non renseigné")
        .Range("H13").Select
        Exit Sub
    End If
    If .Range("G13") = "" Then 'Verif Sous Dossier renseigné
        MsgBox ("Sous Dossier non renseigné")
        .Range("G13").Select
        Exit Sub
    End If
    If .Range("F13") = "" Then 'Verif Fichier renseigné
        MsgBox ("Nom fichier non renseigné")
        .Range("F13").Select
        Exit Sub
    End If

    'Definir des variables
    Emp_Dossier = "C:\" & .Range("H13") 'Chemin a adapter
    Emp_SsDossier = Emp_Dossier & "\" & .Range("G13")
    Emp_Fichier = Emp_SsDossier & "\" & .Range("F13") & ".xlsm"

    'Si le dossier n'est pas créé, alors création du dossier puis sous dossier puis fichier
    If Dir(Emp_Dossier, vbDirectory) = vbNullString Then MkDir (Emp_Dossier)
    If Dir(Emp_SsDossier, vbDirectory) = vbNullString Then MkDir (Emp_SsDossier)
    If Dir(Emp_Fichier, vbDirectory) = vbNullString Then
        ChDir Emp_SsDossier
        ActiveWorkbook.SaveAs Filename:=Emp_Fichier, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    End If
End With
End Sub

A+

Le 28/08/2023 à 15:05

J'ai déjà un morceau de code d'un projet précédent mais justement j'aimerais savoir comment ou je doit changer, enfin je crois savoir ou mais disons que j'ai pas forcement la syntaxe et je ne suis pas sur de se que je m'apprête a changer.

Private Function RepertoireSauvegarde(cPathRacine As String, cPathAAAA As String) As Boolean
Dim objFSO As FileSystemObject
   RepertoireSauvegarde = False
   ' Création de l'objet de manipulation de fichiers
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   ' Complète le path avec \ si nécessaire
   If (Right$(cPathRacine, 1) <> "\") Then cPathRacine = cPathRacine & "\"
   ' teste l'existence du dossier et le crée s'il n'existe pas
   If (objFSO.FolderExists(cPathRacine & cPathAAAA) = False) Then
      On Error Resume Next
      objFSO.CreateFolder (cPathRacine & cPathAAAA)
      If (Err.Number = 0) Then
         ' Pas d'erreur donc création du dossier OK
         RepertoireSauvegarde = True
      Else
         MsgBox "Erreur " & Err.Number & " - " & Err.Description
         Err.Clear
      End If
   Else
      ' Le dossier existe donc c'est OK
      RepertoireSauvegarde = True
   End If
   ' Libération de l'objet
   Set objFSO = Nothing

   On Error GoTo 0
End Function

Sub Save()
Dim cPathRacine As String
Dim cPathAAAA As String
  Application.ScreenUpdating = False 'supprime l'affichage donc + rapide
  Application.DisplayAlerts = False '(supprime les messages)
  Dim i As Byte, n_fichier As String, wk As Workbook, n_feuille As String, sh As Worksheet, prem_date As Date, no_semaine As Byte 'déclaration des variables propre à cette macro
  nomfich = ActiveWorkbook.Name
  prem_date = DateSerial(Year(Range("H13").Value), 1, 1) '1°janvier
  ctrl = True 'pour que les macros combobox change ne fonctionne pas
  ActiveWorkbook.Save 'sauvegarde du fichier

  cPathRacine = Range("Feuil2!G13")
  cPathAAAA = Format(Range("G13").Value, "mmm") & " " & Range("H13")
  If (RepertoireSauvegarde(cPathRacine, cPathAAAA) = True) Then

    n_feuille = Format(Range("D14").Value, "dd") & ")" & " " & Range("Feuil2!F16") & "_" & Format(Range("D14").Value, "mmm yy") 'nom de la feuille= date+nom+date exemple : 11) NOTE DE FRAIS_nov 2022.xlsx
    ActiveSheet.Copy After:=Sheets(Sheets.Count) 'copy la feuille en dernier
    ActiveSheet.Name = n_feuille 'renomme la feuille
    Set sh = ActiveSheet 'affecte cette feuille à une variable

    n_fichier = cPathRacine & cPathAAAA & "\" & n_feuille & ".xlsx" 'chemin et nom du fichier
    Set wk = Workbooks.Add(xlWBATWorksheet) 'ajoute un fichier
    sh.Copy After:=wk.Sheets(Sheets.Count) 'copie la feuille dans ce fichier
    Sheets("Feuil1").Delete 'supprime la feuille créé à la creation du fichier
    ActiveWorkbook.SaveAs Filename:=n_fichier, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'sauvegarde le fichier avec cette feuille
    ActiveWorkbook.Close 'ferme le fichier
    sh.Delete 'supprime la feuille ajouté dans le fichier principal
    MsgBox "Fichier sauvegardé sous " & n_fichier 'message...

  Else
    MsgBox "Le fichier n'a pas pu être sauvegardé ..."
  End If

  ctrl = False ' supprime la variable ctrl
  Sheets("Feuil1").Select 'selectionne la feuille tableau
  Application.ScreenUpdating = True 'affichage en service
  Application.DisplayAlerts = True 'alerte possible
End Sub
Rechercher des sujets similaires à "sauvegarde automatique dossier"