Mettre un mdp sur un fichier selon une cellule défini par macro VBA

Bonjour,

Je viens faire appel à vous après avoir chercher plusieurs heure une solution, fait de nombreux test non concluant...

Voilà j'ai fait une petite macro pour que je puisse enregistrer automatiquement un fichier selon un nom défini (NOM_TYPE_date) jusqu'à la tout va bien,

par contre je souhaites que ce fichier lorsqu'il s'enregistre bénéficie d'un mot de passe personnalisé (je traite des données sensible) Le mot de passe doit être le suivant : cgs+1ère lettre du Nom de famille + Nb de caractère dans le nom de famille. pour me simplifier la tache je pensais créer une cellule avec formule qui reprendrais directement ces éléments puis je ferais pointé mon mdp sur cette cellule.

SAuf que impossible de faire pointer mon mot de passe sur une cellule défini.

J'arrive à générer un mdp lorsque je le défini directement dans le code mais cela fait qu'il ne sera pas unique pour chaque fichier enregistré.

Voici le code que j'ai actuellement

Sub EnregistrerSous()

   ClasseurSource = ActiveWorkbook.Name
   'nommer le nom du classeur avant enregistrement
    On Error Resume Next
     Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Password = Range("D14").Value
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" _
        & Range("D16").Value & "_" & Range("G7").Value & "_" & Range("D14").Value & "_" & Format(Date, "yymmdd") & ".xlsm"
    Application.DisplayAlerts = True
    'supprimer l'ancien fichier
    Kill ClasseurSource
    'fermer le classeur
    ThisWorkbook.Close SaveChanges:=True

End Sub

La partie enregistrement fonctionne parfaitement mais pour la partie mdp on y est pas,

si quelqu'un à une solution je suis preneuse :D

En remerciant par avance toute personne qui prendra du temps pour m'aider

Cordialement

Yuukia

Salut Yuukia,

ainsi, sans doute : testé et fonctionnel chez moi.
!!! ATTENTION : je n'ai pas testé avec [D14] ou [D16] ou [G7] vides !!!
Le code est à placer dans le module 'ThisWorkbook' avec toutes les adaptations requises par le fichier réel !

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'
Dim sItem$
'
ClasseurSource = ActiveWorkbook.Name
'nommer le nom du classeur avant enregistrement
On Error Resume Next
Application.DisplayAlerts = False
With Worksheets("Feuil1")
    sItem = "cgs" & UCase(Left(.[D14], 1)) & Trim(CStr(Len(.[D14])))
    ActiveWorkbook.SaveAs Password:=sItem
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" _
    & .[D16] & "_" & .[G7] & "_" & .[D14] & "_" & Format(Date, "yymmdd") & ".xlsm"
End With
Application.DisplayAlerts = True
'supprimer l'ancien fichier
Kill ClasseurSource
'fermer le classeur
ThisWorkbook.Close SaveChanges:=True
On Error GoTo 0
'
End Sub

A+

Hello,

merci pour ton Code, finalement j'ai réussi avec cette macro :

Sub EnregistrerSous()

    ClasseurSource = ActiveWorkbook.Name

    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & UCase(Range("D17").Value) & "_" & Range("G7").Value & "_" & UCase(Range("D15").Value) & "_" & Format(Date, "yymmdd") & "_ENVOI" & ".xlsm", Password:=Range("G6").Value
    Application.DisplayAlerts = True

    Kill ClasseurSource

    ThisWorkbook.Close SaveChanges:=True

End Sub

Cependant j'ai un nouveau soucis, je dois à partir d'une autre macro ouvrir ces fichiers dont chaque mot de passe est unique. Comme le mot de passe est liée au nom du fichier j'ai ça :

mdp = ClasseurSource
            mdp = Split(mdp, "_")(2)
            mdp = "Rem" & Left(UCase(mdp), 1) & Len(mdp)

Cependant, après plusieurs test je me retrouve ennuyé lorsque je n'ai pas de donnée dans le Nom de famille de la personne (le mdp était Rem + Première lettre du nom de famille + nb caractère du nom de famille) Ainsi j'ai décidé de changer en remplaçant le nom de famille par l'emploi mais pour corser un peu le sujet, il ne faut prendre que le premier mot de l'emploi (par exemple si l'emploi = controleur de gestion social je ne compte que le nombre de caractère de controleur soit 10 caractère) si j'ai réussi à definir le nb de caractère sous excel avec un CHERCHE, je n'y arrive pas sous VBA car je n'ai plus les _ pour borner les données que je prend.

Ah et je viens de me souvenir de la demande supplémentaire de mon chef ou il veut que la première lettre soit forcement en majuscule peut importe comment elle est écrite (facile sous excel bcp moins sous VBA)

Si tu as une solution ou quelque chose qui pourrait m'aider je suis preneuse :)

Si je ne suis pas assez clair n'hésite pas à me le dire :)