Sauvegarde multiple dans un autre répertoire

Version imprimable

Bonsoir à la communauté.

J'ai un code pour sauvegarder un fichier Excel partagé, à chaque fois qu'un utilisateur utilise (et enregistre) le fichier.

Code dans le module :

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
Public Sub SaveCopy()
    Dim strDate As String
    Dim Count   As Integer
    Dim PosSep As Integer
 
 
 
    Count = Len(ActiveWorkbook.Name)
    PosSep = InStrRev(ActiveWorkbook.Name, ".")
    '--- Extension xls ou xlsm (3 ou 4 car.)
    If PosSep = 0 Then
 
        NameA = ActiveWorkbook.Name
    Else
        NameA = Left(ActiveWorkbook.Name, PosSep - 1)
    End If
    '--- Ajout séparateur si besoin
    If Right(ActiveWorkbook.Path, 1) <> "\" Then
        NameA = ActiveWorkbook.Path & "\" & NameA
    Else
        NameA = ActiveWorkbook.Path & NameA
    End If
    '---
    strDate = Format(Date, "dd-mm-yy") & "_" & Format(Time, "hh-mm-ss")
    ThisWorkbook.SaveCopyAs Filename:=NameA & "_" & Environ$("username") & "_" & strDate & Right(ActiveWorkbook.Name, Count - PosSep + 1)
End Sub

Code dans ThisWorkbook :

Code:

1
2
3
4
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    '--- Sauve le fichier avec le nom et ajout de Date_Heure
    Call SaveCopy
End Sub

Je souhaiterais que les sauvegardes puissent être réalisées sous un autre répertoire que celui du fichier.
Quelqu'un peut-il m'aider à trouver la bonne syntaxe à rajouter à mon code.
Merci par avance.

Bonjour,

Remplace "ActiveWorkbook.Path" par le chemin du dossier désiré :

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
37
38
39
40
41
42
43
44
45
 
Public Sub SaveCopy()
 
    Dim strDate As String
    Dim Count As Integer
    Dim PosSep As Integer
    Dim NameA As String
    Dim Chemin As String
 
    Count = Len(ActiveWorkbook.Name)
 
    PosSep = InStrRev(ActiveWorkbook.Name, ".")
 
    '--- Extension xls ou xlsm (3 ou 4 car.)
    If PosSep = 0 Then
 
        NameA = ActiveWorkbook.Name
 
    Else
 
        NameA = Left(ActiveWorkbook.Name, PosSep - 1)
 
    End If
 
    Chemin = "D:\Mon Dossier\"
 
    NameA = Chemin & NameA
 
'''''    '--- Ajout séparateur si besoin
'''''    If Right(ActiveWorkbook.Path, 1) <> "\" Then
'''''
'''''        NameA = ActiveWorkbook.Path & "\" & NameA
'''''
'''''    Else
'''''
'''''        NameA = ActiveWorkbook.Path & NameA
'''''
'''''    End If
 
    '---
    strDate = Format(Date, "dd-mm-yy") & "_" & Format(Time, "hh-mm-ss")
 
    ThisWorkbook.SaveCopyAs Filename:=NameA & "_" & Environ$("username") & "_" & strDate & Right(ActiveWorkbook.Name, Count - PosSep + 1)
 
End Sub

Hervé.

06/04/2014, 12h15
janigrel

Merci Hervé. C'est exactement ce que je voulais. J'avais essayé en vain avec ChDir...
Si vous souhaitez prolonger votre aide, j'ai créé une nouvelle discussion pour l'exécution d'une macro par lien hypertexte :
=> http://www.developpez.net/forums/d14...en-hypertexte/

Encore merci.
Janigrel