Enregistrement auto dans mes documents

bcharly Messages postés 12 Statut Membre -  
 Kristobal45 -
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...
A voir également:

8 réponses

Réponse 1 / 8
Utilisateur anonyme
 
re :

Je Regarde !

Lupin
0
Réponse 2 / 8
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
bcharly Messages postés 12 Statut Membre
 
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
Réponse 3 / 8
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
Réponse 4 / 8
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
bcharly Messages postés 12 Statut Membre
 
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

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

Posez votre question
Réponse 5 / 8
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
bcharly Messages postés 12 Statut Membre
 
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
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
Réponse 6 / 8
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
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
Réponse 7 / 8
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
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
Réponse 8 / 8
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
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 -
Lilou -

2 réponses
Table des matières dont les titres n'apparaissent pas..
Synua -
ggg -

10 réponses
imprimer ses documents dans des magasins
dogfriend -
yggdrasoli -

4 réponses