Sauvegarde Automatique dans un sous dossier
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
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
@ +
Bonjour,
En complément :
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+
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