VBA enregistrement auto d'un fichier Excel

Résolu/Fermé

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009 - 21 janv. 2009 à 12:38
bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009 - 3 févr. 2009 à 12:57

Bonjour,

Je voudrais pouvoir enregistrer un programme Excel en automatique, sous un autre nom et la condition suivante :

- L’utilisateur est sur un ordi relié à un serveur dont l’enregistrement doit être effectué sous le chemin « L:\Dossier utilisateurs\Archives offres »
- L’utilisateur est sur un ordi autonome (dans ce cas, l’enregistrement se fera directement dans C:\)

A ce jour, j’arrive en un clic à enregistrer automatiquement le programme sous un autre nom grâce à la macro ci-dessous :

Sub enregistreroffre()
If Sheets("Offre").Range("AO19") = "2" Then Application.Run "miseenpageimpclient"
Sheets("Offre").Select
Sheets("Offre").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A17").Select
Dim Chemin
Chemin = "C:\"
Dim MonFichier
MonFichier = Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
ActiveWorkbook.SaveAs Filename:=MonFichier, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
MsgBox ("Fichier créé dans C:\")
End Sub

Mon problème est que par défaut, l’enregistrement se fait dans C:
Est-il possible de créer une 2ème macro similaire :

Sub enregistreroffreserveur()
If Sheets("Offre").Range("AO19") = "2" Then Application.Run "miseenpageimpclient"
Sheets("Offre").Select
Sheets("Offre").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A17").Select
Dim Chemin
Chemin = " L:\Dossier utilisateurs\Archives offres"
Dim MonFichier
MonFichier = Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
ActiveWorkbook.SaveAs Filename:=MonFichier, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
MsgBox ("Fichier créé dans L:\Dossier utilisateurs\Archives offres ")
End Sub

Dans ce cas, quelle macro faire pour que si l’utilisateur n’a pas le chemin « L:\Dossier utilisateurs\Archives offres » prend la macro « Sub enregistreroffre() »
Dans l’esprit Excel ma requête est :
Si(L:\Dossier utilisateurs\Archives offres=VRAI ; Sub enregistreroffreserveur()
; Sub enregistreroffre())

Si vous avez une solution, merci d’avance…

A voir également:

VBA enregistrement auto d'un fichier Excel
Fichier bin - Guide
Comment ouvrir un fichier epub ? - Guide
Comment réduire la taille d'un fichier - Guide
Fichier rar - Guide
Fichier .dat - Guide

8 réponses

Réponse 1 / 8

Bidouilleu_R Messages postés 1181 Date d'inscription mardi 27 mai 2008 Statut Membre Dernière intervention 12 juillet 2012 295
21 janv. 2009 à 13:15

je réponds OUI mais je pense que tu devras tester l'existence du fichier

si le fichier n'existe pas ( chemin ou fichier inexistant ou les deux ou mauvaise orthographe)
le gestionnaire d'erreur renvoie 53.
Dis moi si ça convient?

je ferai une fonction comme ça

Sub test()
chemin = "C:\DATA\"
fichier = "essai.txt"
fichier1 = "essai2.xls"
If isFileExist(chemin + fichier) Then
'existe
'je sauvegarde
Else
'n'existe pas
'je sauvegarde là
End If
End Sub

Function isFileExist(filename As String)
Dim NumFichier As Integer, Errnum As Integer
Err.Clear
On Error Resume Next
NumFichier = FreeFile()
Open filename For Input Lock Read As #NumFichier
Close NumFichier
Errnum = Err
On Error GoTo 0
Select Case Errnum
Case 0
isFileExist = True
Case 53
isFileExist = False

End Select

End Function

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009
21 janv. 2009 à 13:45

Merci pour ton aide Bidouilleu

J'ai essayé de retranscrire ce que tu m'a préconisé mais je dois certainement être à côté de la plaque car il me met "Erreur de compilation Sub ou Function non défini"
Voilà comment j'ai integré tes formules :

Sub enregistreroffreserveur()
Sheets("Offre").Select
Sheets("Offre").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A17").Select
Dim Chemin
Chemin = " L:\Dossier utilisateurs\Archives offres\"
Dim MonFichier
MonFichier = Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
ActiveWorkbook.SaveAs Filename:=MonFichier, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
MsgBox ("Fichier créé dans L:\Dossier utilisateurs\Archives offres ")
End Sub

Sub enregistreroffre()
Sheets("Offre").Select
Sheets("Offre").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A17").Select
Dim Chemin
Chemin = "C:\"
Dim MonFichier
MonFichier = Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
ActiveWorkbook.SaveAs Filename:=MonFichier, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
MsgBox ("Fichier créé dans C:\")
End Sub

Sub test()
Chemin = "L:\Dossier utilisateurs\Archives offres\"
If isFileExist(Chemin) Then
Application.Run "enregistreroffreserveur"
Else
Application.Run "enregistreroffre"
End If
End Sub

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009
21 janv. 2009 à 14:16

Apres modification, la macro de bug plus mais même si le chemin existe, le fichier est enregister dans c:/
La formule enregistrée est :

Sub test()
Chemin = "C:\DATA\"
fichier = "essai.txt"
fichier1 = "essai2.xls"
If isFileExist("L:\Dossier utilisateurs\Archives offres\") Then
Application.Run "enregistreroffreserveur"
Else

Application.Run "enregistreroffre"
End If
End Sub

Function isFileExist(filename As String)
Dim NumFichier As Integer, Errnum As Integer
Err.Clear
On Error Resume Next
NumFichier = FreeFile()
Open filename For Input Lock Read As #NumFichier
Close NumFichier
Errnum = Err
On Error GoTo 0
Select Case Errnum
Case 0
isFileExist = True
Case 53
isFileExist = False

End Select

End Function

Par contre, je ne vois pas à quoi servent "fichier" et "fichier1"

...

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009
21 janv. 2009 à 15:45

Il faut que le chemin soit identique pour que le programme enregistre le fichier.
Mais le fichier enregistrer n'a jamais le même nom que celui d'origine. C'est peut être pour cela que je n'arrive pas à faire fonctionner ton programme. Il me parait pourtant adapté à ma demande (à un poil pret !). Il faut impérativement que la comparaison se fasse sur le chemin et qu'il ne prenne pas en compte le nom du fichier d'origine.
Ton programme peut-il s'adapter à ce que j'ai indiqué ci-dessus ?

Réponse 2 / 8

Bidouilleu_R Messages postés 1181 Date d'inscription mardi 27 mai 2008 Statut Membre Dernière intervention 12 juillet 2012 295
21 janv. 2009 à 14:14

A quel endroit se produit l'erreur?

la routine sub test() est faite pour te montrer comment fonctionne la
fonction que j'ai écrite isfileexist

tu dois donc mettre à l'extérieure d'une sub cette fonction
je parle de cette fonction

Function isFileExist(filename As String)
Dim NumFichier As Integer, Errnum As Integer
Err.Clear ' efface les erreurs antérieures
On Error Resume Next
NumFichier = FreeFile()
Open filename For Input Lock Read As #NumFichier 'je fais ouverture/fermeture en lecture seule
Close NumFichier
Errnum = Err ' je récupère le n° d'erreur
On Error GoTo 0
Select Case Errnum
Case 0
isFileExist = True
Case 53
isFileExist = False

End Select

End Function

Réponse 3 / 8

michel_m Messages postés 16602 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 313
21 janv. 2009 à 14:17

Bonjour,

peut-être une alternative
cette fonction indique si on est en local ou sur le réseau

Function dire_lecteur()
Dim fso As Object
Dim lecteur As Object

  Set fso = CreateObject("Scripting.FileSystemObject")
  For Each lecteur In fso.Drives
  Select Case lecteur.drivetype
    Case 2
        dire_lecteur = "local"
        Exit For
    Case 3
        dire_lecteur = "reseau"
        Exit For
    End Select
  Next
End Function

pouur essayer la fonction
sub test
msgbox lire_lecteur
end if

Réponse 4 / 8

Bidouilleu_R Messages postés 1181 Date d'inscription mardi 27 mai 2008 Statut Membre Dernière intervention 12 juillet 2012 295
22 janv. 2009 à 09:50

Tu dis :
"
Il faut que le chemin soit identique pour que le programme enregistre le fichier. Mais le fichier enregistrer n'a jamais le même nom que celui d'origine. C'est peut être pour cela que je n'arrive pas à faire fonctionner ton programme. Il me parait pourtant adapté à ma demande (à un poil pret !). Il faut impérativement que la comparaison se fasse sur le chemin et qu'il ne prenne pas en compte le nom du fichier d'origine.
Ton programme peut-il s'adapter à ce que j'ai indiqué ci-dessus ?

OUI

' le test pour te montrer comment ça Marche ^^
Sub test()
Chemin = "L:\TonDossier" '
AccèsDossier Chemin
If AccèsDossier Then
'sauvegarde en réseau
Else
'sauvegarde en local
'tu peux faire le même test en local
End If
End Sub

Function AccèsDossier(Dossier)
Err.Clear ' efface les erreurs antérieures
On Error Resume Next

Dir Dossier & "\*.*" ' Le dossier Courant existe toujours il s'appelle "." son parent c'est ".."
'si tu ne peux pas lire la seconde entrée par exemple droit d'accès => erreur 52
'
Errnum = Err ' je récupère le n° d'erreur

Select Case Errnum
Case 0
AccèsDossier = True
Case 52
' problème de droit d'accès
AccèsDossier = False
Case Else
'autre erreur la procédure n'aboutiras pas
AccèsDossier = False
End Select

End Function

Tu peux aussi t'inspirer de la fonction de michel_M (post 3 ) ...
Il y a toujours plusieurs méthodes pour un même résultat.

R

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009
22 janv. 2009 à 13:32

Après avoir inputé ta procédure, l'erreur 449 apparait. Erreur de compilation: Argument non facultatif. Cette erreur apparait su la formule "If AccèsDossier Then"

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 8

Bidouilleu_R Messages postés 1181 Date d'inscription mardi 27 mai 2008 Statut Membre Dernière intervention 12 juillet 2012 295
22 janv. 2009 à 13:53

définit AccèsDossier comme variable booléenne

et
retest

AccèsDossier = False
Sub test()
Dim AccèsDossier as boolean

Chemin = "L:\TonDossier" '
AccèsDossier Chemin
If AccèsDossier Then
'sauvegarde en réseau
Else
'sauvegarde en local
'tu peux faire le même test en local
End If
End Sub

Réponse 6 / 8

Utilisateur anonyme
22 janv. 2009 à 14:24

Bonjour,

suggestion :

Sub EnregistrerOffre()

    Dim Chemin As String, MonFichier As String
    Dim NomDossier As String, Message As String

    If Sheets("Offre").Range("AO19") = "2" Then
        Application.Run "miseenpageimpclient"
    End If
    
    Sheets("Offre").Select
    Sheets("Offre").Copy
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                            :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A17").Select
    Chemin = " L:\Dossier utilisateurs\Archives offres"
    MonFichier = Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
    NomDossier = Left(MonFichier, InStrRev(MonFichier, "\"))
    If DossierExiste(NomDossier) Then
        ActiveWorkbook.SaveAs Filename:=MonFichier, _
                FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
                ReadOnlyRecommended:=False, CreateBackup:=False
        Message = "Fichier créé dans L:\Dossier utilisateurs\Archives offres\"
    Else
        Chemin = "C:\"
        MonFichier = Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
        ActiveWorkbook.SaveAs Filename:=MonFichier, _
                FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
                ReadOnlyRecommended:=False, CreateBackup:=False
        Message = "Fichier créé dans C:\"
    End If
    MsgBox Message
    
End Sub
'

Function DossierExiste(ByVal NomDossier As String) As Boolean

    Dim objFS As Object, objDossier As Object
   
    Set objFS = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set objDossier = objFS.GetFolder(NomDossier)
    If Error = "Chemin d'accès introuvable" Then
        DossierExiste = False
    Else
        DossierExiste = True
    End If
   
End Function
'

Lupin

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009
3 févr. 2009 à 08:58

Bonjour Lupin.A

Suite à l'aide bien précieuse que tu m'as fourni le 22 janvier dernier,...
J'aimerais que tu m'aides sur le théme "Enregistrement auto dans Mes documents"
Envoyé sur le forum le 2 février.

D'avance, merci.

Utilisateur anonyme > bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009
3 févr. 2009 à 12:25

re:

je ne trouve pas la file, peux-tu placer un hyperlien vers cette file ?

Lupin

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009 > Utilisateur anonyme
3 févr. 2009 à 12:57

http://www.commentcamarche.net/forum/affich 10842040 enregistrement auto dans mes documents?#1

Réponse 7 / 8

Bidouilleu_R Messages postés 1181 Date d'inscription mardi 27 mai 2008 Statut Membre Dernière intervention 12 juillet 2012 295
22 janv. 2009 à 14:30

très bien!

Réponse 8 / 8

bcharly Messages postés 12 Date d'inscription mercredi 21 janvier 2009 Statut Membre Dernière intervention 4 février 2009
22 janv. 2009 à 15:27

La suggestion de Lupin fonctionne. Merci beaucoup.
Merci également à Bidouilleu pour son aide pendant ces 2 jours.
C'est la 1ère fois que je passais par un forum pour avoir des réponses à mes problèmes et je suis impréssionné par la rapidité et la solidarité. Encore merci à tous et certainement à trés bientôt sur la toile...