none
Excel worksheet code issue RRS feed

  • Question

  • I have racked my brain and cannot figure out why this fails. The sheet will work correctly if you select "Close" or click on the upper right hand "X". But when I allow the ontime event to invoke the close command from within the standard module, the code in the worksheet module appears to execute and you can set breakpoints and step through each line, but none of the code is actually executing.
    In Module1
    
    Option Explicit
    
    Dim DownTime As Date
    Sub SetTimer()
        DownTime = Now + TimeValue("00:01:00")
        Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=True
    End Sub
    Sub StopTimer()
        On Error Resume Next
        Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=False
    End Sub
    Sub ShutDown()
    Call ThisWorkbook.ShutDownNow
    End Sub
    
    In WorkSheet
    
    Option Explicit
    Public EmailSheet As Worksheet
    Public MyPWord As String
    Private Sub Workbook_Open()
    Call SetTimer
    Worksheets("Notes & PassWord").Activate
    End Sub
    Public Sub ShutDownNow()
    Call StopTimer
    ThisWorkbook.Close
    End Sub
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.ScreenUpdating = False
    PwordSheets
    Worksheets("Notes & PassWord").Activate
        If ThisWorkbook.Saved = False Then
            ThisWorkbook.Save
        End If
    Application.ScreenUpdating = True
    End Sub
    Sub PwordSheets()
    MyPWord = "email"
        For Each EmailSheet In ActiveWorkbook.Worksheets
            EmailSheet.Unprotect Password:=MyPWord
        Next EmailSheet
    SortData
    SetCellDefault
        For Each EmailSheet In ActiveWorkbook.Worksheets
            EmailSheet.Protect Password:=MyPWord
    Next EmailSheet
    End Sub
    Sub SortData()
    For Each EmailSheet In Worksheets
        If EmailSheet.Name <> "Notes & PassWord" Then
           EmailSheet.Sort.SortFields.Clear
           EmailSheet.Range("A1").CurrentRegion.Sort key1:=EmailSheet.Range("A2"), order1:=xlAscending, order2:=xlAscending, Header:=xlYes
        End If
    Next EmailSheet
    End Sub
    Sub SetCellDefault()
    For Each EmailSheet In Worksheets
        If EmailSheet.Name <> "Notes & PassWord" Then
           EmailSheet.Activate
           Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        End If
     Next EmailSheet
    End Sub
    Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
        Call StopTimer
        Call SetTimer
    End Sub
    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
        Call StopTimer
        Call SetTimer
    End Sub
    


    Glenn

    Saturday, April 21, 2018 4:40 PM

Answers

  • I copied your code into a workbook, and created a sheet named Notes & PassWord.

    If I open this workbook and don't do anything with it, it is closed after one minute without prompting (and the sheets are sorted etc.).

    If I change something, then wait a minute, I get a prompt whether I want to save changes. You should move the lines

    PwordSheets
    Worksheets("Notes & PassWord").Activate
        If ThisWorkbook.Saved = False Then
           
    ThisWorkbook.Save
       
    End If

    from Workbook_BeforeClose to ShutDownNow, above the line ThisWorkbook.Close.

    If the code doesn't run for you: are you sure that you allow macros when you open the workbook?


    Regards, Hans Vogelaar (http://www.eileenslounge.com)


    Saturday, April 21, 2018 6:26 PM

All replies

  • I copied your code into a workbook, and created a sheet named Notes & PassWord.

    If I open this workbook and don't do anything with it, it is closed after one minute without prompting (and the sheets are sorted etc.).

    If I change something, then wait a minute, I get a prompt whether I want to save changes. You should move the lines

    PwordSheets
    Worksheets("Notes & PassWord").Activate
        If ThisWorkbook.Saved = False Then
           
    ThisWorkbook.Save
       
    End If

    from Workbook_BeforeClose to ShutDownNow, above the line ThisWorkbook.Close.

    If the code doesn't run for you: are you sure that you allow macros when you open the workbook?


    Regards, Hans Vogelaar (http://www.eileenslounge.com)


    Saturday, April 21, 2018 6:26 PM
  • Hans,

    Thanks a much, worked great. I did want to keep the beforeclose even though because lots of people just hit the upper "X" and I wanted the functions to work. I also added some if statements in the timer trigger code  keep the loop from triggering the timer during sort, pword and default cursor functions.

    Here's the final code and it appears to work without issues.

    Glenn Swaney

    module1 NO CHANGE ThisWorksheet Option Explicit Public EmailSheet As Worksheet Public MyPWord As String Public NoTimer As Boolean Private Sub Workbook_Open() Call SetTimer

    NoTimer = False Worksheets("Notes & PassWord").Activate End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) If NoTimer = False Then Call StopTimer NoTimer = True Application.ScreenUpdating = False PwordSheets Worksheets("Notes & PassWord").Activate If ThisWorkbook.Saved = False Then ThisWorkbook.Save End If Application.ScreenUpdating = True End If End Sub Public Sub ShutDownNow() Call StopTimer NoTimer = True Application.ScreenUpdating = False PwordSheets Worksheets("Notes & PassWord").Activate If ThisWorkbook.Saved = False Then ThisWorkbook.Save End If Application.ScreenUpdating = True ThisWorkbook.Close End Sub Sub PwordSheets() MyPWord = "email" For Each EmailSheet In ActiveWorkbook.Worksheets EmailSheet.Unprotect Password:=MyPWord Next EmailSheet SortData SetCellDefault For Each EmailSheet In ActiveWorkbook.Worksheets EmailSheet.Protect Password:=MyPWord Next EmailSheet End Sub Sub SortData() For Each EmailSheet In Worksheets If EmailSheet.Name <> "Notes & PassWord" Then EmailSheet.Sort.SortFields.Clear EmailSheet.Range("A1").CurrentRegion.Sort key1:=EmailSheet.Range("A2"), order1:=xlAscending, order2:=xlAscending, Header:=xlYes End If Next EmailSheet End Sub Sub SetCellDefault() For Each EmailSheet In Worksheets If EmailSheet.Name <> "Notes & PassWord" Then EmailSheet.Activate Range("A" & Rows.Count).End(xlUp).Offset(1).Select End If Next EmailSheet End Sub Private Sub Workbook_SheetCalculate(ByVal Sh As Object) If NoTimer = False Then Call StopTimer Call SetTimer End If End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) If NoTimer = False Then Call StopTimer Call SetTimer End If End Sub




    Glenn

    Sunday, April 22, 2018 3:07 AM
  • Hate to bother you again but is there a way to have a floating digital display of the countdown value from the ontime event whereas the user can see the time remaining regardless which sheet he is on?

    Glenn


    Glenn

    Monday, April 23, 2018 4:43 PM
  • I wouldn't recommend doing that. You'd need another OnTime routine with a fairly short interval, 5 seconds or so; this might interfere with the normal operation of Excel.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, April 23, 2018 6:38 PM
  • Hans,

    Thanks for the reply. Sorry for the next question as I am a novice.

    Isn't there a way to access the ontime value as it counts down and display that in a userform?

    Glenn


    Glenn

    Tuesday, April 24, 2018 3:37 AM
  • Sorry, no.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, April 24, 2018 6:48 AM