Enregistrement auto dans mes documents

bcharly -  
Bonjour,

Je voudrais pouvoir enregistrer un fichier Excel automatiquement avec VBA dans "Mes documents" sachant que le fichier en question peut-être utilisé par différents PC (donc différentes sessions utilisateurs)

Aujourd'hui, ne connaissant pas le nom de l'utilisateur automatiquement, j'ai fais la macro ci dessous :

Sub EnregistrerOffre()
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

Afin de ne plus enregistrer "grossièrement" dans C: mais dans un dossier bien défini, je voudrais donc que le chemin soit :

C:\Documents and Settings\"Session de l'utilisateur"\Mes documents\

Si vous avez une solution, d'avance merci...
Configuration: Windows XP
Internet Explorer 7.0

8 réponses

  1. Utilisateur anonyme
    re :

    Je Regarde !

    Lupin
    0
    1. Utilisateur anonyme
      re:

      Voici : 

      Sub EnregistrerOffre()

    Dim Lecteur As String, Chemin As String
    Dim Message As String, MonFichier As String
    
    Lecteur = "C:"
    Chemin = "\Documents and Settings\" & TrouveUtilisateur
    Chemin = Chemin & "\Mes Documents\"
    
    If DossierExiste(Lecteur & Chemin) Then
        MonFichier = Lecteur & Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
        ActiveWorkbook.SaveAs Filename:=MonFichier, _
            FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
        Message = "Fichier créé dans " & Lecteur & Chemin
    Else
        Chemin = "\Temp\"
        If DossierExiste(Lecteur & Chemin) Then
            MonFichier = Lecteur & Chemin & Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
            ActiveWorkbook.SaveAs Filename:=MonFichier, _
                FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
                ReadOnlyRecommended:=False, CreateBackup:=False
            Message = "Fichier créé dans " & Lecteur & Chemin
        Else
            Message = "Impossible de trouver un répertoire valide!"
        End If
    End If
    
    MsgBox Message
    
End Sub
'


Function TrouveUtilisateur() As String

    Dim oWsh As Object, oWshEnv As Object
    
    Set oWsh = CreateObject("WScript.Shell")
    Set oWshEnv = oWsh.Environment("PROCESS")
    TrouveUtilisateur = oWsh.ExpandEnvironmentStrings("%username%")
    Set oWshEnv = Nothing
    Set oWsh = Nothing
    
End Function
'

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
      0
      1. bcharly Auteur
        C'est exactement le résultat que je désirais !!!!

        Merci 1000 fois !

        Ne serait-cepas trop te demander s'il y a possibilité d'ajouter un dossier dans Mes documents ?

        J'aimerais que VB créé un fichier "Archive" automatiquement s'il n'existe pas encore. De cette manière, les enregistrements ne se trouveraient plus dans "Mes documents" mais dans "Mes documents\Archives\"

        ???
        0
    2. Utilisateur anonyme
      re:

      Nouvelle version :-) 

      Option Explicit
'

Sub EnregistrerOffre()

    Dim Lecteur As String, Chemin As String
    Dim Message As String, MonFichier As String
    Dim NomFichier As String
    
    NomFichier = Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
    Lecteur = "C:"
    Chemin = CreationDossierArchive(Lecteur)
    If (Chemin <> "") Then
        Chemin = Lecteur & Chemin
        If DossierExiste(Chemin) Then
            MonFichier = Chemin & NomFichier
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs MonFichier
            Application.DisplayAlerts = True
            Message = "Fichier créé dans : " & vbLf & Chemin & vbLf
            Message = Message & vbLf & "Le chemin d'accès : " & vbLf & MonFichier
        Else
            Chemin = "\Temp\"
            If DossierExiste(Lecteur & Chemin) Then
                MonFichier = Lecteur & Chemin & NomFichier
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs MonFichier
                Application.DisplayAlerts = True
                Message = "Fichier créé dans : & vblf " & Chemin & vbLf
                Message = Message & vbLf & "Le chemin d'accès : " & vbLf & MonFichier
            Else
                Message = "Impossible de trouver un répertoire valide!"
            End If
        End If
    Else
        Message = "Impossible de trouver un répertoire valide!"
    End If
    MsgBox Message
    
End Sub
'

Function CreationDossierArchive(ByVal strLecteur As String) As String

    Dim strChemin As String, strUtilisateur As String

    strUtilisateur = TrouveUtilisateur
    strChemin = "\Documents and Settings\" & TrouveUtilisateur
    strChemin = strChemin & "\Mes Documents\"
    If DossierExiste(strLecteur & strChemin) Then
        If (DossierExiste(strLecteur & strChemin & "Archives")) Then
            CreationDossierArchive = strChemin & "Archives\"
        Else
            ChDrive strLecteur
            ChDir strChemin
            MkDir "Archives"
            CreationDossierArchive = strChemin & "Archives\"
        End If
    Else
        CreationDossierArchive = ""
    End If

End Function
'

Function TrouveUtilisateur() As String

    Dim oWsh As Object, oWshEnv As Object
    
    Set oWsh = CreateObject("WScript.Shell")
    Set oWshEnv = oWsh.Environment("PROCESS")
    TrouveUtilisateur = oWsh.ExpandEnvironmentStrings("%username%")
    Set oWshEnv = Nothing
    Set oWsh = Nothing
    
End Function
'

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
      0
      1. Utilisateur anonyme
        re:

        J'ai oublié de libérer les instances dans la fonction [ DossierExiste ]. 

        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
    Set objDossier = Nothing
    Set objFS = Nothing
   
End Function
'

        Lupin
        0
        1. bcharly Auteur
          Ca fonctionne. Respect.
          Par contre, si le fichier a déjà été enregistré sous le même nom, il est écrasé alors qu'auparavant, il était signalé et on avait le choix de le remplacer ou non. Est-ce normal ?
          0
      3. Utilisateur anonyme
        re:

        Pas vraiment, j'ai codé cet état de chose ???

        Désolé, mais je code disons de façon systématique ...
        Ça dépend toujours de ce que l'on veut obtenir.

        Peut-être que la concatenation de :
        Range("AH1").Value & "_" & Range("AH2").Value & ".xls"
        m'avait fait penser que tu avais prévue un compteur de version.

        Regarde ces instructions : 
                    Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs MonFichier
            Application.DisplayAlerts = True


        Juste avant la sauvegarde, les messages d'alerte sont désactivés
        et juste après la sauvegarde, ils sont réactivés.

        Si et seulement si tu ne dois pas écraser le(s) fichier(s),
        enlève ces quatres lignes de la procédure [ Sub EnregistrerOffre() ]

        Un exemple des deux cas ( donc 2 lignes à supprimer ou placer en commentaires ) 
                    MonFichier = Chemin & NomFichier
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs MonFichier
            Application.DisplayAlerts = True

par

            MonFichier = Chemin & NomFichier
            'Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs MonFichier
            'Application.DisplayAlerts = True

ou

            MonFichier = Chemin & NomFichier
            ActiveWorkbook.SaveAs MonFichier


        En toute amitié :-) du Québec

        Lupin
        0
        1. bcharly Auteur
          Merci d'avoir répondu à toutes mes demandes. Il ne me reste plus qu'à analyser toutes ces requêtes afin de bien comprendre leur fonctionnement.
          Tu m'a permis de gagner beaucoup de temps.

          Amitié également,

          De la part d'un gars du nord de la france.

          Eh ouais...mi chuis ch'ti !!!
          0
        2. Kristobal45
          Bonjour,

          J'ai put lire tes recommandations sur le forum et j'ai été surpris pas ton efficacité.

          Je cherche un code VBA qui me permettrait de faire des sauvegardes automatiques avec incrémentation du nom du fichier. Pour le moment j'en suis là:

          Sub numero()
          Dim num As Integer
          Dim nom As String
          Dim numLigne As String

          Range("N1").Select
          num = Range("N1").Value
          num = num + 1
          Range("N1").Value = num

          numLigne = ActiveCell.Row

          nom = "Fiche_" & num & "_" & Format(Date, "dd-mm-yyyy") & ".xls"
          ActiveWorkbook.SaveAs "C:\Documents and Settings\STAGESG-ADC\Bureau\Test BDD\" & " SG " & nom

          End Sub

          Mon problème est que je souhaite travailler à partir d'un fichier modèle (à utiliser comme formulaire) du coup mon numéro d'incrémentation n'est pas sauvegardé et repars à "1". Comment faire? je crois avoir vu des fonctions de type "autonumber", "autoincrement" ou "assign number" mais je ne suis parvenu à aucun résultat concluant. Je crois savoir qu'il faudrait que je créé un autre fichier qui me servirait de compteur mais je ne suis pas parvenu à indiquer le chemin du fichier dans mon.
          Aurais tu l'amabilité de me prêter conseil?!

          Merci par avance.
          Chris
          0
      4. Utilisateur anonyme
        Bonjour,

        Alors voici une suggestion : 

        Option Explicit

Sub Numero()

    Dim intNum As Integer
    Dim strNom As String
    Dim strLigne As String

    With ActiveSheet
        .Range("N1").Select
        intNum = (.Range("N1").Value + 1)
        .Range("N1").Value = intNum
        strLigne = ActiveCell.Row
    End With
    ' Ici il faut sauvegarder le modèle
    ' avec le numéro incrémenter
    ActiveWorkbook.Save

    strNom = "Fiche_" & intNum & "_" & Format(Date, "dd-mm-yyyy") & ".xls"
    ' Ici j'ai volontairement enlevé l'espace qui précède
    ' le début du nom, soit : [ SG ]
    ' Il n'est certes pas recommandé de commencer le nom d'un fichier
    ' par un espace !!!
    ActiveWorkbook.SaveAs "C:\Documents and Settings\STAGESG-ADC\Bureau\Test BDD\" & "SG " & strNom

End Sub
'


        p.s. déformation professionnel, j'ai modifié les noms de variables.

        Lupin
        0
        1. Kristobal45
          Bonjour Lupin,

          Merci pour ta suggestion, je viens de tester ton code mais mon compteur reste toujours à "1". En effet une sauvegarde du fichier est faite mais sous que modèle. Ce que je souhaiterai est en fait une "numérotation" comme pour le modèle "facture" (invoice.xlt) que l'on trouve sous EXCEL. La fonction s'intitule "attribuer un numéro". Je souhaiterai que seul le compteur s'incrémente dans mon modèle sans garder les données saisies dans mon formulaire (modèle).
          Il faudrait que mon compteur garde le dernier enregistrement dans le modèle (ou dans un fichier annexe qu'on appelerait "increment_numero" par exemple).
          Le but étant que je puisse à chaque fois remplir mon modèle comme un formulaire, que le fichier soit sauvegardé sous un nom type fiche_001, puis fiche_002 et ainsi de suite... pour cela il faut que mon compteur s'incrémente et soit sauvegardé.

          J'ai déjà fait plusieurs tests et recherches sur le net avec ces éléments mais je bloque, mes connaissance sous VB sont limitées, ce serait sympa de ta part de me proposer une solution.

          Merci d'avance.
          Chris
          0
      5. Utilisateur anonyme
        Bonjour,

        Voilà, je n'avais pas réalisé que tu travaillais avec un modèle ( XLT ).

        Donc, lorsque tu ouvre le modèle, celui-ci est transformé en ( XLS ).

        Il suffit donc, à ce moment d'ouvrir le modèle pour incrémenter le compteur,
        et de saugarder le modèle et de le fermer.

        Exemple type : 

        Option Explicit

Sub Numero()

    Dim intNum As Integer, strNom As String, strZero As String

    intNum = LireInfoFichier
    With Sheets("Feuil1")
        .Range("N1").Value = intNum
    End With
    
    If (intNum < 10) Then
        strZero = "00"
    Else
        If (intNum > 9) And (intNum < 100) Then
            strZero = "0"
        Else
            If (intNum > 99) Then
                strZero = ""
            End If
        End If
    End If
    
    strNom = "Fiche_" & strZero & intNum & "_" & Format(Date, "dd-mm-yyyy") & ".xls"
    ActiveWorkbook.SaveAs "C:\Documents and Settings\STAGESG-ADC\Bureau\Test BDD\" & "SG " & strNom
    'ActiveWorkbook.SaveAs "C:\Document\Programmation\VBA\Excel\" & "SG " & strNom

End Sub
'

Function LireInfoFichier() As Integer

    Const cteCheminModele = "C:\Document\Programmation\VBA\Excel\"
    Const cteNomModele = "Invoice.xlt"
    
    Dim strCheminFichier As String
    
    strCheminFichier = cteCheminModele & cteNomModele
    Workbooks.Open Filename:=strCheminFichier, Editable:=True
    With Sheets("Feuil1")
        LireInfoFichier = (.Range("N1").Value + 1)
        .Range("N1").Value = LireInfoFichier
    End With
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
End Function
'


        Testé et fonctionnel sur XL2003.

        n.b. Ce code doit être placé dans le modèle et les chemins déclarés en constante doivent
        être adapté.

        Lupin
        0
        1. Kristobal45
          Bonjour à nouveau LUPIN.A

          Encore un grand merci pour ta préciseuse contribution.

          J'ai testé le code que tu m'as transmis en metant à jour les chemins. Tout se déroule presque bien...
          Je rencontre une "erreur d'execution 9 Indice en dehors de la plage", le débogage m'indique que l'erreur se trouve sur la ligne "With sheets ("Feuil1") dans la fonction LireInfoFichier.

          As tu une idée sur la cause de cette erreur? Je te colle ci dessous le code avec les chemins modifiés ainsi que la ligne ou apparait l'erreur (en gras).

          Une autre précision, je suis sous EXCEL 97.
          J'attends de tes news et encore merci
          Chris

          Option Explicit

          Sub Numero()

          Dim intNum As Integer, strNom As String, strZero As String

          intNum = LireInfoFichier
          With Sheets("Feuil1")
          .Range("N1").Value = intNum
          End With

          If (intNum < 10) Then
          strZero = "00"
          Else
          If (intNum > 9) And (intNum < 100) Then
          strZero = "0"
          Else
          If (intNum > 99) Then
          strZero = ""
          End If
          End If
          End If

          strNom = "Fiche_" & strZero & intNum & "_" & Format(Date, "dd-mm-yyyy") & ".xls"
          ActiveWorkbook.SaveAs "C:\Documents and Settings\STAGESG-ADC\Bureau\FDA SG" & "SG " & strNom
          'ActiveWorkbook.SaveAs "C:\Document\Programmation\VBA\Excel\" & "SG " & strNom

          End Sub
          '

          Function LireInfoFichier() As Integer

          Const cteCheminModele = "C:\Program Files\Microsoft Office\Modèles\"
          Const cteNomModele = "Modele_FDA"

          Dim strCheminFichier As String

          strCheminFichier = cteCheminModele & cteNomModele
          Workbooks.Open FileName:=strCheminFichier, Editable:=True
          With Sheets("Feuil1")
          LireInfoFichier = (.Range("N1").Value + 1)
          .Range("N1").Value = LireInfoFichier
          End With
          ActiveWorkbook.Save
          ActiveWorkbook.Close

          End Function
          0
      6. Utilisateur anonyme
        re:

        Dans le fichier modèle ( XLT ), le code incrémente un compteur localisé
        en cellule [ N1 ].

        Donc dans ton code original, la cellule [ N1 ] est spécifié, mais pas le feuille.

        Pour adresser une cellule, il est toujours souhaitable de spécifier la feuille.

        With Sheets("Feuil1")

        Ici, le nom de la feuille est [ Feuil1 ], donc regarde dans le fichier modèle
        et remplace [ Feuil1 ] par le nom de la feuille qui détient la cellule N1 du compteur.

        Il est souhaitable de cibler la feuille, car si tu enregistre le modèle en pointant
        une autre feuille, c'est celle-ci qui sera active à l'ouverture.

        Me suis-je fais comprendre ?

        Lupin
        0
        1. Kristobal45
          Bonjour LUPIN.A

          Eh bien j'ai testé ton code en suivant tes instructions et ça fonctionne parfaitement.

          Mon compteur s'incrémente bien sur mon modèle et mes fichiers sont correctement sauvegardés.

          Je te suis reconnaissant de ton amabilité, ta réactivité et ta patience.

          Merci pour ta précieuse contribution.

          Chris
          0

      Discussions similaires

      Comment supprimer un contact
      Lilou

      2 réponses
      contacts non supprimables ou modifiables sur ma carte sim
      saxoline

      5 réponses
      Impossible de supprimer mes contacts
      evanora74

      6 réponses
      imprimer ses documents dans des magasins
      dogfriend

      4 réponses
      disque dur et bbox bouygues
      t671

      1 réponse