Création d'un sous dossier avec chemin variable et sauvegarde du fichier

Question

Après de multiples recherches, je n’arrive pas à finaliser mon fichier Excel et j’aurai besoin de votre aide. Je vous explique mon projet : J’ai un fichier Excel source « GRIMP 25 » qui est enregistré dans un dossier « 10-FMPA » sur un serveur avec 3 sous-dossiers déjà créé (BESANCON ; MONTBELIARD ; PONTARLIER). J’aimerai à la fermeture de mon fichier Excel, que celui-ci choisisse le sous-dossier BESANCON ou MONTBELIARD ou PONTARLIER en fonction de la valeur de la cellule E6 de l’onglet « DONNEES ». Si la cellule : • E6 = EST = sous-dossier MONTBELIARD • E6 = OUEST = sous-dossier BESANCON • E6 = SUD = sous-dossier PONTARLIER À l’issue de la sélection du bon sous-dossier, j’aimerai créer un nouveau sous-dossier avec pour nom les valeurs des cellules B10 & la date de la cellule B2. (Exemple : Michael-08-05-2020). Dès le sous-dossier créé avec les valeurs des cellules B10 & la date de la cellule B2, je souhaiterai que mon fichier Excel « GRIMP 25 » s’enregistre avec les mêmes valeurs (cellules B10 & B2) au format xlsm. Exemple (Michael-08-05-2020.xlsm) Par contre quand on ouvre celui-ci (Michael-08-05-2020.xlsm), interdire la modification des cellules E6,B10 et B2 mais par contre autoriser la modification des autres cellules déverrouillées et à la fermeture on sauvegarde en écrasant le fichier en cours. De même si à la fermeture du fichier source « GRIMP 25 » les cellules E6,B10 et B2 n’ont pas été renseignées, un message d’alerte doit s’afficher pour informer l’utilisateur qu’aucun nom(B10), date (B2) et groupement (E6) n’ont été renseigné et que s’il valide le message d’alerte, le fichier ne sera PAS enregistré. Je vous remercie pour l’aide que vous m’apporterez. Prenez soin de vous. Michael...

BrunoM45 · Answer

Avec ton fichier et le code, ce serait plus simple...

BrunoM45 · Answer

Re,

ATTENTION !

Ton fichier contient des données personnelles, merci de bien vouloir le remplacer par un anonymisé STP

Sinon, est-ce que ce code doit être conservé à la fermeture ?

Dim fichier As String
On Error Resume Next
ChDir "C:\Users\"
Do
    fichier = Application.GetSaveAsFilename( _
    fileFilter:="Excel Files (*.xlsm), *.xlsm")
    nom = Split(fichier, "\")
    For i = 1 To UBound(nom)
        If i = UBound(nom) Then Mot = nom(i)
        Mot = Left(nom(i), Len(nom(i)) - 5)
    Next i
    TW = ThisWorkbook.Name
    Wk = Left(TW, Len(TW) - 5)
    If Mot <> Wk Then
        If fichier <> False Then
            ThisWorkbook.SaveCopyAs fichier
            End
            Exit Do
        End If
    End If
Loop While 1 = 1

@+

ThauThème · Answer

Bruno a été plus rapide mais je me permets quand même de t'envoyer ma proposition puisque j'y planche depuis quelques temps. La copie est au format xlsx pour éviter que le code se déclenche sur le fichier copié : Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim CO As Workbook 'déclare la varaible CO (Classeur Original) Dim OS As Worksheet 'déclare la varaible OS (Onglet Source) Dim CA As String 'déclare la varaible CA (Chemin d'Accès) Dim SD As String 'déclare la varaible SD (Sous Dossier) Set CO = ThisWorkbook 'définit le classeur original CO Set OS = CO.Worksheets("DONNEES") 'définit l'onglet source OS CA = CO.Path &amp; "\" 'définit le chemin d'accès CA With OS.Range("B2") 'prend en compte la cellule B2 de l'onglet OS If .Value = "" Then 'condition : si vide MsgBox "Vous devez renseigner une date!" 'message .Select 'sélectionne Cancel = True 'annule la fermeture du classeur Exit Sub 'sort de la procédure End If 'fin de la condition End With 'fin de la prise en compte de la cellule B2 de l'onglet OS With OS.Range("B10") 'prend en compte la cellule B10 de l'onglet OS If .Value = "" Then 'condition : si vide MsgBox "Vous devez renseigner un nom !" 'message .Select 'sélectionne Cancel = True 'annule la fermeture du classeur Exit Sub 'sort de la procédure End If 'fin de la condition End With 'fin de la prise en compte de la cellule B10 de l'onglet OS With OS.Range("E6") 'prend en compte la cellule E6 de l'onglet OS If .Value = "" Then 'condition : si vide MsgBox "Vous devez renseigner le groupement !" 'message .Select 'sélectionne Cancel = True 'annule la fermeture du classeur Exit Sub 'sort de la procédure End If 'fin de la condition End With 'fin de la prise en compte de la cellule E6 de l'onglet OS SD = Range("B10").Value &amp; "-" &amp; Format(Range("B2").Value, "dd-mm-yyyy") 'définit le sous dossier SD On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante) ChDir CA &amp; SD 'définit le dossier courant (génère une erreur si ce dossier n'existe pas If Err &lt;&gt; 0 Then 'condition : si une erreur a été générée Err.Clear 'supprime l'erreur MkDir CA &amp; SD 'crée un sous dossier de CA End If 'fin de la condition On Error GoTo 0 'annule la gestion des erreurs Application.DisplayAlerts = False 'empêche les message d'Excel CO.SaveAs CA &amp; SD &amp; "\" &amp; SD, FileFormat:=51 'enregiste le fichier au format xlsx ActiveWorkbook.Worksheets("DONNEES").Range("B2,B10,E6").Locked = True 'verrouille les cellues B2, B10 et E6 Worksheets("DONNEES").Protect 'protège l'onglet ActiveWorkbook.Save 'sauve le classeur Application.DisplayAlerts = True 'aurorise les message d'Excel End Sub...

BrunoM45 · Answer

Je n'ai pas été plus rapide, je n'ai encore rien donné Sinon voici le fichier anonymisé, un petit truc à régler peut-être à la fermeture du classeur Edit : Mika25, il faudra juste nous dire si tu veux la copie du classeur sans Macros @+...

eriiic · Answer

Thauthème, si j'ai bien lu ton code, j'ai l'impression que tu ne mets pas toutes les cellules à .Locked = False (=True par défaut non ?) avant de bloquer les interdites. eric Edit : mika25, quand tu as une erreur il faut donner la ligne ET le message...

ThauThème · Answer

Re, @Mika Désolé Mika, pas ce problème chez moi... @Éric Je ne peux pas deviner celles qui sont verrouillées et celles qui ne le sont pas. Je n'ai donc verrouillé que celles demandées.....

BrunoM45 · Answer

Opus désolé, j'avais zappé cette notion

Voici le code à remplacer

Sub EnrClasseur(bFlag As Boolean)
  Dim sDos As String, sSDos As String, sSSDos As String
  Dim sNom As String, sDate As String, Secteur As String
  ' Vérifier que le classeur est bien l'original sinon on sort
  If ThisWorkbook.Name <> "Mika25_GRIMP 25.xslm" Then Exit Sub  
  ' Chemin d'accès de ce fichier
  sDos = ThisWorkbook.Path & "\"
  ' Avec la feuille à traiter
  With ThisWorkbook.Sheets("DONNEES")
    ' Nom et date
    sNom = .Range("B10").Value
    sDate = Format(.Range("B2").Value, "dd.mm.yyyy")
    Secteur = .Range("E6").Value
  End With
  ' Vérifier si toutes les informations sont ok
  If sNom = "" Or sDate = "" Or Secteur = "" Then
    ' Sinon alerter l'utilisateur
    If MsgBox("Toutes les informations nécessaires ne sont pas enregistrées" & vbCr _
      & "La copie du fichier ne sera pas créée, voulez-vous continuer ?", vbQuestion + vbYesNo + vbDefaultButton2, "ATTENTION...") = vbYes Then
      FlgClose = True
      Exit Sub
    Else
      FlgClose = False
      Exit Sub
    End If
  End If
  ' Protéger les cellules E6, B2, B10
  With ThisWorkbook.Sheets("DONNEES")
    .Unprotect Password:="Pontus"
    .Range("B2,E6:F6,B10:C10").Locked = True
    .Protect Password:="Pontus"
  End With
  ' Choix du sous dossier en fonction de E6
  Select Case Secteur
    Case "EST"
      sSDos = "MONTBELIARD"
    Case "OUEST"
      sSDos = "BESANCON"
    Case "SUD"
      sSDos = "PONTARLIER"
  End Select
  ' Dossier final
  sSSDos = sNom & "-" & sDate
  ' Si le dossier n'existe pas, le créer
  On Error Resume Next
  MkDir sDos & sSDos & "\" & sSSDos
  On Error GoTo 0
  ' Enregistrer le fichier dans ce dossier
  ThisWorkbook.SaveCopyAs sDos & sSDos & "\" & sSSDos & "\" & sSSDos & ".xlsm"
End Sub

Edit, non il y avait autre chose à changer (la 1ère ligne) pour vérifie que le classeur est l'original

@+

ThauThème · Answer

Re,

J'avais oublier de traiter les regroupements, Bruno l'a fait mais j'envoie quand même le code corrigée :

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim CO As Workbook 'déclare la varaible CO (Classeur Original)
Dim OS As Worksheet 'déclare la varaible OS (Onglet Source)
Dim CA As String 'déclare la varaible CA (Chemin d'Accès)
Dim RG As String 'déclare la variable RG (ReGroupement)
Dim SD As String 'déclare la varaible SD (Sous Dossier)

Set CO = ThisWorkbook 'définit le classeur original CO
Set OS = CO.Worksheets("DONNEES") 'définit l'onglet source OS
CA = CO.Path & "\" 'définit le chemin d'accès CA
With OS.Range("B2") 'prend en compte la cellule B2 de l'onglet OS
    If .Value = "" Then 'condition : si vide
        MsgBox "Vous devez renseigner une date!" 'message
        .Select 'sélectionne
        Cancel = True 'annule la fermeture du classeur
        Exit Sub 'sort de la procédure
    End If 'fin de la condition
End With 'fin de la prise en compte de la cellule B2 de l'onglet OS
With OS.Range("B10") 'prend en compte la cellule B10 de l'onglet OS
    If .Value = "" Then 'condition : si vide
        MsgBox "Vous devez renseigner un nom !" 'message
        .Select 'sélectionne
        Cancel = True 'annule la fermeture du classeur
        Exit Sub 'sort de la procédure
    End If 'fin de la condition
End With 'fin de la prise en compte de la cellule B10 de l'onglet OS
With OS.Range("E6") 'prend en compte la cellule E6 de l'onglet OS
    If .Value = "" Then 'condition : si vide
        MsgBox "Vous devez renseigner le groupement !" 'message
        .Select 'sélectionne
        Cancel = True 'annule la fermeture du classeur
        Exit Sub 'sort de la procédure
    End If 'fin de la condition
End With 'fin de la prise en compte de la cellule E6 de l'onglet OS
Select Case OS.Range("E6").Value 'agit en fonction de la cellule E6 de l'onglet OS
    Case "EST" 'cas
        RG = "MONTBELIARD\" 'définit la variable RG
    Case "OUEST" 'cas
        RG = "BESANCON\" 'définit la variable RG
    Case "SUD" 'cas
        RG = "PONTARLIER\" 'définit la variable RG
End Select 'fin de l'action en fonction de la cellule E6 de l'onglet OS
SD = Range("B10").Value & "-" & Format(Range("B2").Value, "dd-mm-yyyy") 'définit le sous dossier SD
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
ChDir CA & RG & SD 'définit le dossier courant (génère une erreur si ce dossier n'existe pas
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    MkDir CA & RG & SD 'crée un sous dossier de CA
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Application.DisplayAlerts = False 'empêche les message d'Excel
CO.SaveAs CA & RG & SD & "\" & SD, FileFormat:=51 'enregiste le fichier au format xlsx
ActiveWorkbook.Worksheets("DONNEES").Range("B2,B10,E6").Locked = True 'verrouille les cellues B2, B10 et E6
Worksheets("DONNEES").Protect 'protège l'onglet
ActiveWorkbook.Save 'sauve le classeur
Application.DisplayAlerts = True 'aurorise les message d'Excel
End Sub