Enregistrement fichier en fonction contenu cellule

[piobote]

Bonjour tout le monde,

J'ai un dossier "DOSSIERXLS" qui contient trois fichiers: deborah.xls, Julie.xls et pierre.xls.Ce dossier se trouve sur E:\
J'ai créée un modèle "saisie.xlt" et la cellule "A1" de ce fichier contiendra le nom de l'utilisateur (soit deborah, julie ou pierre)
Je voudrais qu'à l'enregistrement de mon fichier "saisie" que la feuille active du classeur s'enregistre en dernière position dans le fichier ayant le même nom que le nom saisi dans la cellule "A1"

Par exemple:

Si A1 = pierre, la feuille active se mettra en dernière position dans le fichier pierre.xls
Si A1 = julie, la feuille active se mettra en dernière position dans le fichier julie.xls
Si A1 = deborah, la feuille active se mettra en dernière position dans le fichier deborah.xls

Merci pour votre aide

 

[jp14]

Re : Enregistrement fichier en fonction contenu cellule

Bonjour

Ci dessous une macro a tester. Sauf erreur il n'y a pas de modification à faire.
Les fichiers doivent dans le même répertoire qui doit être le répertoire actif d'excel.

Option Explicit

Sub enregistrer()
Dim nomfeuille1 As String
Dim col1 As String
Dim classeur1 As String
Dim lidep1 As Long
Dim chemin As String
Dim sh As Worksheet
Dim classeur2 As String
Dim i As Integer
Dim data1 As String

'**********************************
' récupération des noms
chemin = ThisWorkbook.Path & "\"
classeur1 = ActiveWorkbook.Name
nomfeuille1 = ActiveSheet.Name  '

With Workbooks(classeur1).Sheets(nomfeuille1)
' recherche du nom du classeur et ouverture
classeur2 = .Range("a1").Value & ".xls"  ' par exemple"Facture.xls"
        Workbooks.Open Filename:=chemin & classeur2
 ' on vérifie si la feuille n'est pas existante       
        For Each sh In Sheets()
        If sh.Name = nomfeuille1 Then
            Call MsgBox("La feuille est déjà enregistrée", vbInformation, Application.Name)
            Application.ScreenUpdating = False 'gele l'ecran
            Application.DisplayAlerts = False 'interdit les messages d'avertissements
            ActiveWorkbook.Close
            Exit Sub
        End If
        Next sh
    
    ' copie de la feuille 
        .Copy After:=Workbooks(classeur2).Sheets(Workbooks(classeur2).Worksheets.Count)
        ActiveSheet.Name = nomfeuille1
        ActiveWorkbook.Save
        ActiveWorkbook.Close
    End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

JP