Enregistrement auto dans mes documents

Question

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

Utilisateur anonyme · Answer

re :

Je Regarde !

Lupin

Utilisateur anonyme · Answer

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

Utilisateur anonyme · Answer

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

Utilisateur anonyme · Answer

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

Utilisateur anonyme · Answer

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

Utilisateur anonyme · Answer

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

Utilisateur anonyme · Answer

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

Utilisateur anonyme · Answer

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

Enregistrement auto dans mes documents

8 réponses

Discussions similaires

Newsletters