XL 2019 Comment mettre plusieurs répertoires dans ce code.

BALANCIE

XLDnaute Junior
Bonjour,
J'ai un code qui marche à merveille, ais j'aurai besoin de mettre les sauvegardes avec dates et limitations dans 2 répertoires supplémentaires et non dans le répertoire de travail.
Comment faire ?
Merci de votre aide.
BALANCIE

VB:
Sub savefichier()
    Dim chemin$, dat As Date, f, a&, oldfich$
    chemin = ThisWorkbook.Path & "\"
    BaseName = "monfichier"
    dat = Now()
    f = Dir(chemin & "monfichier*.xls*")
    Do While f <> ""
        a = a + 1
        fdt = CDate(FileDateTime(chemin & f))
        If f <> ThisWorkbook.Name Then If fdt < dat Then dat = CDate(fdt): oldfich = chemin & f
        f = Dir
    Loop
    If a >= 3 Then Kill oldfich
    ThisWorkbook.SaveCopyAs chemin & BaseName & "_" & Format(Now, "dd-mm-yyyy hh""H""mm""m""ss") & ".xlsm"
    ActiveWorkbook.Save
End Sub
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Balancie,
A tester :
VB:
Sub savefichier()
    Dim chemin$, dat As Date, f, a&, oldfich$
    chemin1 = "C:\Users\PC_PAPA\Desktop\"
    chemin2 = "C:\Users\PC_PAPA\Desktop\XLD\"
    BaseName = "monfichier"
    dat = Now()
    f = Dir(chemin & "monfichier*.xls*")
    Do While f <> ""
        a = a + 1
        fdt = CDate(FileDateTime(chemin & f))
        If f <> ThisWorkbook.Name Then If fdt < dat Then dat = CDate(fdt): oldfich = chemin & f
        f = Dir
    Loop
    If a >= 3 Then Kill oldfich
    ThisWorkbook.SaveCopyAs chemin1 & BaseName & "_" & Format(Now, "dd-mm-yyyy hh""H""mm""m""ss") & ".xlsm"
    ThisWorkbook.SaveCopyAs chemin2 & BaseName & "_" & Format(Now, "dd-mm-yyyy hh""H""mm""m""ss") & ".xlsm"
    ActiveWorkbook.Save
End Sub
 

BALANCIE

XLDnaute Junior
Bonjour Sylanu.
C'était aussi bête que cela. Quel idiot je suis.
Merci.

Cela dit cela fonctionne, mais maintenant la limitation dans les répertoires ne marche plus, alors que dans le premier cas cela s'exécute parfaitement.
J'ai fait un classeur rapidement avec les 2 cas.
Une idée. ?
BALANCIE.
 

Pièces jointes

  • Limite Save.xlsm
    22.4 KB · Affichages: 1

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Je n'ai pas fait attention aux limitations.
Pour faire simple on peut simplement dupliquer la macro avec les deux chemins :
VB:
Sub bonsave()
    Dim chemin1$, chemin2$, dat As Date, f, a&, oldfich$
    chemin1 = "C:\Users\PC_PAPA\Desktop\"       '"C:\Users\R-D\Pictures\Trav\Trav2\"
    chemin2 = "C:\Users\PC_PAPA\Desktop\XLD\"   '"C:\Users\R-D\Pictures\Trav\Trav1\"
    BaseName = "monfichier"
    dat = Now()
    
    ' Traitement Chemin1
    f = Dir(chemin1 & "monfichier*.xls*")
    a = 0
    Do While f <> ""
        a = a + 1
        fdt = CDate(FileDateTime(chemin1 & f))
        If f <> ThisWorkbook.Name Then If fdt < dat Then dat = CDate(fdt): oldfich = chemin1 & f
        f = Dir
    Loop
    If a >= 3 Then Kill oldfich
    ThisWorkbook.SaveCopyAs chemin1 & BaseName & "_" & Format(Now, "dd-mm-yyyy hh""H""mm""m""ss") & ".xlsm"
    
    ' Traitement Chemin2
    f = Dir(chemin2 & "monfichier*.xls*")
    a = 0
    Do While f <> ""
        a = a + 1
        fdt = CDate(FileDateTime(chemin2 & f))
        If f <> ThisWorkbook.Name Then If fdt < dat Then dat = CDate(fdt): oldfich = chemin & f
        f = Dir
    Loop
    If a >= 3 Then Kill oldfich
    ThisWorkbook.SaveCopyAs chemin2 & BaseName & "_" & Format(Now, "dd-mm-yyyy hh""H""mm""m""ss") & ".xlsm"
    
    ' save current file
    ActiveWorkbook.Save
    Select Case MsgBox(" Les Sauvegardes sont réussies - ", , "Toutes les  Sauvegardes.")
    End Select
End Sub
 

Pièces jointes

  • Limite Save.xlsm
    19.9 KB · Affichages: 3

BALANCIE

XLDnaute Junior
Bonsoir Sylanu.
Cela fonctionne en effet.
Mais une fois les 3 sauvegardes faites, à la quatrième j'ai une erreur à la ligne :Then Kill oldfich.
Merci encore pour l'aide, mais cela fait plusieurs jours que je suis dessus.
Je craque.. Cela me semblait pourtant tout simple.
BALANCIE.

Then Kill oldfich
 

patricktoulon

XLDnaute Barbatruc
re
bonjour à tous
et ouais!! il est parti d'un code à Patrick
ça va marcher beaucoup moins bien forcement
diabolo.gif
 

Discussions similaires

Réponses
2
Affichages
241

Statistiques des forums

Discussions
311 720
Messages
2 081 900
Membres
101 834
dernier inscrit
Jeremy06510