VBA enregistrement auto d'un fichier Excel Résolu

Question

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…

Bidouilleu_R · Answer

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

Bidouilleu_R · Answer

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

michel_m · Answer

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

Bidouilleu_R · Answer

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

Bidouilleu_R · Answer

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

Utilisateur anonyme · Answer

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

Bidouilleu_R · Answer

très bien!

bcharly · Answer

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...

VBA enregistrement auto d'un fichier Excel

8 réponses

Discussions similaires

Newsletters