Menu

VBA enregistrement auto d'un fichier Excel [Résolu/Fermé]

Messages postés
12
Date d'inscription
mercredi 21 janvier 2009
Statut
Membre
Dernière intervention
4 février 2009
- - Dernière réponse : 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…
Afficher la suite 

8 réponses

Messages postés
1184
Date d'inscription
mardi 27 mai 2008
Statut
Membre
Dernière intervention
12 juillet 2012
222
0
Merci
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
-
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
-
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
-
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 ?
Messages postés
1184
Date d'inscription
mardi 27 mai 2008
Statut
Membre
Dernière intervention
12 juillet 2012
222
0
Merci
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
Messages postés
15893
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
28 juin 2019
2765
0
Merci
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




Messages postés
1184
Date d'inscription
mardi 27 mai 2008
Statut
Membre
Dernière intervention
12 juillet 2012
222
0
Merci
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
-
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"
Messages postés
1184
Date d'inscription
mardi 27 mai 2008
Statut
Membre
Dernière intervention
12 juillet 2012
222
0
Merci
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
0
Merci
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
-
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
-
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 -
Messages postés
1184
Date d'inscription
mardi 27 mai 2008
Statut
Membre
Dernière intervention
12 juillet 2012
222
0
Merci
très bien!
Messages postés
12
Date d'inscription
mercredi 21 janvier 2009
Statut
Membre
Dernière intervention
4 février 2009
0
Merci
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...