Enregistrer un fichier sous en VBA

Version imprimable

Bonjour,

J'utilise ce code pour créer un dossier , et ensuite je souhaite enregistrer mon fichier Excel dans ce nouveau dossier.
La création du dossier fonctionne très bien mais j'ai une erreur au moment de l'enregistrement. Il me dise : erreur d exécution 1004, excel n'arrive pas à accéder au fichier. Ensuite je debug je rappui sur le bouton lecture de la console VBA et le fichier s'enregistre. Pourquoi la première fois le fichier n'arrive pas à s'enregistrer.
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 Private Sub dossier_enregistrement(ledir_archive, transporteur_nom, chemin_tmp) Dim chemin As String, Commande As String timestamp = Format(Now, "dd-mm-yyyy-hhnnss") transporteur_nom = Replace(transporteur_nom, " ", "_") 'Crée d'un seul coup tous les répertoires 'et sous-répertoires s'ils sont absents et 'ne touche à rien s'ils sont présents chemin = ("" & ledir_archive & transporteur_nom & "_" & timestamp & "\") chemin_tmp = chemin 'S'assurer d'être sur le bon lecteur où les répertoires 'doivent être créé ChDrive "D" Commande = Environ("comspec") & " /c mkdir " & chemin Shell Commande, 0 timestamps = Format(Now, "dd-mm-yyyy-hhnnss") nomFichier = "" & transporteur_nom & "_" & timestamps & ".xlsm" ActiveWorkbook.SaveAs chemin_tmp & nomFichier End Sub
Merci

Bonjour,

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
Private Function CreationDossier(sDossier) As Long 'Fonction pour créer Dossier de Sauvergarde
 
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
 
End Function
 
Sub UserF10() 'Affiche la fenêtre de sauvergarde
 
    If MsgBox("Etes-vous certain de vouloir sauvegarder ?", vbYesNo + vbQuestion, "Demande de confirmation") = vbYes Then
 
        Sauvegarde 'Si bouton Oui est préssé alors on appelle la fct sauvergarde
 
    End If
 
End Sub
 
Sub Sauvegarde()
 
    On Error GoTo CreerDossier 'Si il y a une erreur alors directement à la ligne CreerDossier
 
    Dim sDossier As String
 
    sDossier = "C:\Documents and Settings\TON PROFIL\Mes documents\Enregistrer\" & Format(Date, "yyyy") & "\" & Format(Date, "mmmm")
    Fichier = "LE NOM DE TON FICHIER" & Format(Date, "dd-mm-yyyy")
 
CreerDossier:
 
    If Err.Number = 1004 Then 'Si dossier pas créer
 
        CreationDossier sDossier 'On le créer en appelant la fct "CreationDossier"
 
    End If
 
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs sDossier & "\" & Fichier & ".xls " 'Sauvergarde du dossier
    Application.DisplayAlerts = True
    MsgBox ("Votre fichier a bien été enregistré") 'Fenêtre d'information
 
    Exit Sub
 
End Sub

Cdt

25/07/2012, 15h36
shakapouet

Parfait j'ai réadapter tes fonctions à mon cas et ça fonctionne nickel.
Merci de ton aide.