Microsoft 365 Sauvegarder et fermer le fichier et + application si c'est le dernier fichier à fermer

Usine à gaz

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,
Je vous souhaite une beau dimanche :)

J'ai un p'tit code pour enregistrer mon fichier à la fermeture et tout fermer (fichier + application) :
VB: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ActiveWorkbook.Save
    ActiveWorkbook.RunAutoMacros Which:=xlAutoClose
End Sub

Jusqu'à maintenant, nous avions toujours un seul fichier Excel ouvert, donc pas de souci.

Pour les nouveaux besoins de notre travail, nous allons avoir 2 voire plus de fichiers ouverts en même temps.
Je cherche le bon code qui permettrait :
- de sauvegarder le fichier que l'on veut fermer et le fermer,
- Et de ne fermer l'application que si c'est le dernier fichier ouvert que nous fermons,

J'ai fait des recherches et tentatives mais je n'ai pas trouvé.
Auriez-vous le bon code ?

Je vous remercie (comme toujours) et je continue mes recherches.
Amicalement,
lionel :)
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour Lionel, cp4, le forum,

L'évènement Close entraîne un 2ème déclenchement de Workbook_BeforeClose donc pour l'éviter :
VB: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Static flag As Boolean
If flag Then Exit Sub
Application.EnableEvents = False
'---
Me.Save
Application.EnableEvents = True
flag = True
If Workbooks.Count = 1 Then Application.Quit Else Me.Close
End Sub
S'il y a d'autres macros à neutraliser on déclarera flag en haut du module.

A+
 
Vote positif 0 Vote négatif
Usine à gaz

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Re-Bonjour Gérard,

J'ai pu insérer ton code dans code code :
VB: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Static flag As Boolean
    If flag Then Exit Sub
    Application.EnableEvents = False
    
    If ActiveSheet.Range("i7") = "ICI" Then
    Application.EnableEvents = False
    MsgBox ("Affecter avant de quitter")
    UsFMsg4.Show
    Cancel = True
    Application.EnableEvents = True
    Exit Sub
    End If
    
    If Sheets("SMS RdV").Range("c27") <> "" Then
    Application.EnableEvents = False
    MsgBox ("envoi SMS avant de quitter")
    Sheets("SMS RdV").Select
    Cancel = True
    Application.EnableEvents = True
    Exit Sub
    End If

    dl = Sheets("RdV_transfert").Range("A" & Rows.Count).End(xlUp).Row
    If Sheets("RdV_transfert").Cells(dl, 4) = "" Then
    Application.EnableEvents = False
    MsgBox ("mettre l'agenda Client à jour du dernier RdV")
    Sheets("RdV_transfert").Select
    Cancel = True
    Application.EnableEvents = True
    Exit Sub
    End If
    
   If Sheets("Appels").Range("n1") = 1 Then
    Application.EnableEvents = False
    Sheets("Appels").Select
    MsgBox ("N° cliqué NON affecté : Normal Dr ?" & Chr(10) & "Affecter ou clic X pour annuler")
    Cancel = True
    ActiveSheet.Unprotect Password:=""
        Columns("N:N").Select
        Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
        Application.EnableEvents = True
        ActiveCell.Offset(0, -3).Select
    Exit Sub
    End If
    
    Sheets("Appels").Select
    Sheets("Appels").Unprotect Password:=""
    Sheets("Appels").Range("m1") = "TEXTBOX FERME"
        With Sheets("Appels").Range("m1").Interior
        .Color = RGB(55, 86, 35)
        End With
    Sheets("Appels").Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True
    With Sheets("Appels")
        .TextBox1.Visible = False
    End With
    'Selection.AutoFilter 'ôte le filtre
    Application.OnKey "%{F8}"
    RétabliMenu
    
    Me.Save
    Application.EnableEvents = True
    flag = True
    If Workbooks.Count = 1 Then Application.Quit Else Me.Close
    End Sub

Mais dans celui-là :
Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'sauvegarde de sécurité
'    On Error Resume Next
'    Application.OnTime t, "Enregistrer", , False 'arrête le processus
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    ActiveWindow.DisplayGridlines = False
    
    Application.Calculation = xlAutomatic
    If ActiveSheet.Name = "SaisieRdV" Then
    If [aa8] <> 19 Then
    MsgBox ("Avant de quitter, traitez votre RdV en cours !")
    Cancel = True
    activeMacros_SaisieRdV
    Exit Sub
    End If
    End If
    
    Sheets("SuivisAppels").Select
    If [t3] <> "OK" Then
     Blocage
     Cancel = True
     Application.ScreenUpdating = False
     Exit Sub
    Else
    ActiveWindow.DisplayHorizontalScrollBar = True
        ActiveWindow.DisplayVerticalScrollBar = True
            Application.DisplayFormulaBar = True
                Application.ScreenUpdating = False
                    Application.EnableEvents = False
                        Application.Calculation = xlManual
    
    Sheets("SuivisAppels").Unprotect Password:="Krameri"
    Sheets("SuivisAppels").Range("a3") = 1
    Sheets("SuivisAppels").Protect Password:="Krameri", DrawingObjects:=True, Contents:=True, Scenarios:=True
    
    Sheets("ArguVendeurs").Unprotect Password:="Krameri"
    Sheets("ArguVendeurs").Range("a1") = 1
    Sheets("ArguVendeurs").Protect Password:="Krameri", DrawingObjects:=True, Contents:=True, Scenarios:=True
    End If
    Application.ScreenUpdating = False
    Sheets("SuivisAppels").Unprotect Password:="Krameri"
'        Dim DL As Long 'Définition de la variable
'        DL = Cells(Application.Rows.Count, 1).End(xlUp).Row 'Je définis la dernière ligne dont la colonne A n'est pas vide
        Range("ac1").Copy
        'Range("ac7:ac20000").Select
        
        Range([ac2], Cells(Rows.Count, "ac").End(xlUp)).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Trie_Ttlignes 'SupprFormats
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        On Error Resume Next
        Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        
        [a3] = 1 'si 2 ne redimentionne pas l'affichage
        [a6].Select
    
    If [t3] = "OK" Then
    RétabliMenu2
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    affichage_normal2
    Application.ScreenUpdating = False
    ActiveWindow.DisplayHeadings = True
     With Application
    .MoveAfterReturn = True
    .MoveAfterReturnDirection = xlToRight
    Application.MoveAfterReturnDirection = xlToRight
    End With
        ActiveWorkbook.Save
        ActiveWorkbook.RunAutoMacros Which:=xlAutoClose
    Else
    CreateObject("Wscript.shell").Popup "Manque infos ou OK !", 1, "Oups"
        Cancel = True
    Application.ScreenUpdating = False
    Range([y7], Cells(Rows.Count, "y").End(xlUp)).Select
    'Columns("y:y").Select
    Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -7).Activate
    ActiveWindow.ScrollRow = Selection.Row
    End If
    Sheets("ClientsCoordonnées").Visible = False
    ActiveWindow.LargeScroll ToRight:=-1
    'Sheets("A Faire").Select
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlAutomatic
    'Sheets("A Faire").Select
    
    Application.EnableEvents = True
    CODE CP4
   With ThisWorkbook
        Application.DisplayAlerts = False
        ActiveWorkbook.Save
        If Workbooks.Count = 1 Then Application.Quit Else .Close
        Application.DisplayAlerts = True
    End With
    End Sub
Je n'y arrive pas lol :)
Je continue d'essayer,
lionel,
 
Vote positif 0 Vote négatif
Usine à gaz

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Usine à gaz à dit:
Re-Bonjour Gérard,

J'ai pu insérer ton code dans ce code :
VB: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Static flag As Boolean
    If flag Then Exit Sub
    Application.EnableEvents = False
  
    If ActiveSheet.Range("i7") = "ICI" Then
    Application.EnableEvents = False
    MsgBox ("Affecter avant de quitter")
    UsFMsg4.Show
    Cancel = True
    Application.EnableEvents = True
    Exit Sub
    End If
  
    If Sheets("SMS RdV").Range("c27") <> "" Then
    Application.EnableEvents = False
    MsgBox ("envoi SMS avant de quitter")
    Sheets("SMS RdV").Select
    Cancel = True
    Application.EnableEvents = True
    Exit Sub
    End If

    dl = Sheets("RdV_transfert").Range("A" & Rows.Count).End(xlUp).Row
    If Sheets("RdV_transfert").Cells(dl, 4) = "" Then
    Application.EnableEvents = False
    MsgBox ("mettre l'agenda Client à jour du dernier RdV")
    Sheets("RdV_transfert").Select
    Cancel = True
    Application.EnableEvents = True
    Exit Sub
    End If
  
   If Sheets("Appels").Range("n1") = 1 Then
    Application.EnableEvents = False
    Sheets("Appels").Select
    MsgBox ("N° cliqué NON affecté : Normal Dr ?" & Chr(10) & "Affecter ou clic X pour annuler")
    Cancel = True
    ActiveSheet.Unprotect Password:=""
        Columns("N:N").Select
        Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
        Application.EnableEvents = True
        ActiveCell.Offset(0, -3).Select
    Exit Sub
    End If
  
    Sheets("Appels").Select
    Sheets("Appels").Unprotect Password:=""
    Sheets("Appels").Range("m1") = "TEXTBOX FERME"
        With Sheets("Appels").Range("m1").Interior
        .Color = RGB(55, 86, 35)
        End With
    Sheets("Appels").Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True
    With Sheets("Appels")
        .TextBox1.Visible = False
    End With
    'Selection.AutoFilter 'ôte le filtre
    Application.OnKey "%{F8}"
    RétabliMenu
  
    Me.Save
    Application.EnableEvents = True
    flag = True
    If Workbooks.Count = 1 Then Application.Quit Else Me.Close
    End Sub

Mais dans celui-là :
Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'sauvegarde de sécurité
'    On Error Resume Next
'    Application.OnTime t, "Enregistrer", , False 'arrête le processus
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    ActiveWindow.DisplayGridlines = False
  
    Application.Calculation = xlAutomatic
    If ActiveSheet.Name = "SaisieRdV" Then
    If [aa8] <> 19 Then
    MsgBox ("Avant de quitter, traitez votre RdV en cours !")
    Cancel = True
    activeMacros_SaisieRdV
    Exit Sub
    End If
    End If
  
    Sheets("SuivisAppels").Select
    If [t3] <> "OK" Then
     Blocage
     Cancel = True
     Application.ScreenUpdating = False
     Exit Sub
    Else
    ActiveWindow.DisplayHorizontalScrollBar = True
        ActiveWindow.DisplayVerticalScrollBar = True
            Application.DisplayFormulaBar = True
                Application.ScreenUpdating = False
                    Application.EnableEvents = False
                        Application.Calculation = xlManual
  
    Sheets("SuivisAppels").Unprotect Password:="Krameri"
    Sheets("SuivisAppels").Range("a3") = 1
    Sheets("SuivisAppels").Protect Password:="Krameri", DrawingObjects:=True, Contents:=True, Scenarios:=True
  
    Sheets("ArguVendeurs").Unprotect Password:="Krameri"
    Sheets("ArguVendeurs").Range("a1") = 1
    Sheets("ArguVendeurs").Protect Password:="Krameri", DrawingObjects:=True, Contents:=True, Scenarios:=True
    End If
    Application.ScreenUpdating = False
    Sheets("SuivisAppels").Unprotect Password:="Krameri"
'        Dim DL As Long 'Définition de la variable
'        DL = Cells(Application.Rows.Count, 1).End(xlUp).Row 'Je définis la dernière ligne dont la colonne A n'est pas vide
        Range("ac1").Copy
        'Range("ac7:ac20000").Select
      
        Range([ac2], Cells(Rows.Count, "ac").End(xlUp)).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Trie_Ttlignes 'SupprFormats
      
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        On Error Resume Next
        Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
      
        [a3] = 1 'si 2 ne redimentionne pas l'affichage
        [a6].Select
  
    If [t3] = "OK" Then
    RétabliMenu2
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    affichage_normal2
    Application.ScreenUpdating = False
    ActiveWindow.DisplayHeadings = True
     With Application
    .MoveAfterReturn = True
    .MoveAfterReturnDirection = xlToRight
    Application.MoveAfterReturnDirection = xlToRight
    End With
        ActiveWorkbook.Save
        ActiveWorkbook.RunAutoMacros Which:=xlAutoClose
    Else
    CreateObject("Wscript.shell").Popup "Manque infos ou OK !", 1, "Oups"
        Cancel = True
    Application.ScreenUpdating = False
    Range([y7], Cells(Rows.Count, "y").End(xlUp)).Select
    'Columns("y:y").Select
    Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -7).Activate
    ActiveWindow.ScrollRow = Selection.Row
    End If
    Sheets("ClientsCoordonnées").Visible = False
    ActiveWindow.LargeScroll ToRight:=-1
    'Sheets("A Faire").Select
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlAutomatic
    'Sheets("A Faire").Select
  
    Application.EnableEvents = True
    CODE CP4
   With ThisWorkbook
        Application.DisplayAlerts = False
        ActiveWorkbook.Save
        If Workbooks.Count = 1 Then Application.Quit Else .Close
        Application.DisplayAlerts = True
    End With
    End Sub
Je n'y arrive pas lol :)
Je continue d'essayer,
lionel,
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif

Discussions similaires

Usine à gaz
  • Résolu(e)
XL 2021 Fermer et enregistrer avec "NOM DE FICHIER" = contenu de A3
2
Réponses
17
Affichages
825
Usine à gaz
Usine à gaz
C
  • Résolu(e)
Autres msgbox : mettre en garde du risque de fermer un fichier
Réponses
7
Affichages
567
fanch55
fanch55
G
  • Question
XL 2019 Fermer fichier PDF si ouvert avant impression
Réponses
9
Affichages
693
patricktoulon
patricktoulon
M
  • Résolu(e)
XL 2013 Fermer tous les fichiers ouverts sauf le fichier actif et Personnal
2
Réponses
19
Affichages
2 K
Merlin258413
M
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Réinitialiser le fichier initial
Réponses
10
Affichages
467
chaelie2015
chaelie2015
H
  • Question
Microsoft 365 Sauvegarder fichier de XLSM à XLSX et effacer contrôle
Réponses
9
Affichages
515
job75
job75
Usine à gaz
  • Question
XL 2021 Besoin de modifier Workbooks("classeur1") selon le classeur ouvert
3 4 5
Réponses
64
Affichages
2 K
TooFatBoy
TooFatBoy
Y
  • Résolu(e)
Microsoft 365 Fermeture d'un Fichier Excel si celui-ci est déjà ouvert
Réponses
12
Affichages
760
Yoyo60
Y
Lu76Fer
  • Question
XL 2016 Evénement BeforeSave plutôt que BeforeClose
2
Réponses
22
Affichages
513
patricktoulon
patricktoulon
B
  • Question
XL 2016 RESOLU _ Reset le minuteur si Userform Actif et activité sur Userform
Réponses
14
Affichages
309
Dranreb
Dranreb

Membres actuellement en ligne

3 membres et 48 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 023
Messages
2 084 715
Membres
102 637
dernier inscrit
TOTO33000