Multifunction Button

David_R

New Member
Joined
Feb 21, 2019
Messages
5
Hi,

My Excel Spreadsheet has:
  • a Shape which is intended to act as a button
  • Column D is hidden
  • Cell F5 is formatted as Time and is currently set to 00:05:00 (i.e. 5 minutes)
  • Cell Range E12:E21 where the user is going to enter values (e.g. answers to questions)

I would like the user to be able to click on the button/shape, and this would:
  • Unhide Column D
  • Start a countdown to zero in Cell F5
  • When the countdown reaches zero the Range E12:E21 are automatically protected/locked so the user can no longer update them (a pop-up message saying "Time's Up!" would be a nice to have, but not essential)

Is it possible to do all three of these things with the one button/shape using VBA and if so what would the code look like?

Thanks
David_R
 

Jeffrey Mahoney

Well-known Member
Joined
May 31, 2015
Messages
1,604
Yes, that is possible

I suggest that a cell not be used for the timer. A form can display over the worksheet while still allowing cell edits which could display the timer. The reason is that the timer cell can't be changed while a user is edited a cell. The form would have to be non modal

Thoughts: There are ways for the user to stop the macro, but it's a little hard for most. If time is up and a user is still editing a cell, it would have to wait for the user to enter the value before locking the range.

Application.Ontime would be used to show the countdown every N seconds

Jeff
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
8,900
Office Version
2007
Platform
Windows
Try this:



Assign the "Initial" macro to your button

change "abc" by the password of your sheet



Before running the macro, I advise you to try with "00:00:08" seconds to see the operation, when you have it ready, change to "00:10:00" minutes



Put the following code in a module:


Code:
Public ahora
Const pwd = "[B][COLOR=#0000ff]abc[/COLOR][/B]"


Sub [B]Initial[/B]()
    ahora = Now
    ActiveSheet.Unprotect pwd
    Range("F5").Value = TimeValue("[COLOR=#0000ff][B]00:10:01[/B][/COLOR]")
    Range("E12:E21").Locked = False
    ActiveSheet.Protect pwd
    Call Down_Count
End Sub


Sub Down_Count()
    ActiveSheet.Unprotect pwd
    Range("F5").Value = Range("F5").Value - TimeValue("00:00:01")
    ActiveSheet.Protect pwd
    DoEvents
    If Range("F5").Value = 0 Then
        On Error Resume Next
        Application.OnTime EarliestTime:=ahora, Procedure:="Down_Count", Schedule:=False
        On Error GoTo 0
        ActiveSheet.Unprotect pwd
        Range("E12:E21").Locked = True
        Range("F5").Value = TimeValue("[B][COLOR=#0000ff]00:10:00[/COLOR][/B]")
        ActiveSheet.Protect pwd
        MsgBox "Time's Up!"
        Exit Sub
    End If
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Down_Count", Schedule:=True
End Sub
 

Jeffrey Mahoney

Well-known Member
Joined
May 31, 2015
Messages
1,604
This is a good start. Try adding the code to unprotect the sheet, unhide column D, and the rest of your start procedures. Use the macro record or search this site for code similar to your needs and adapt it. Let me now if you have questions.

I created a simple form with two labels on it. One named "Time_lbl" to hold the countdown and one called "AllDone_lbl" that displays the final message. You can add as much as you want. Make sure to change the property on the form called ShowModal to FALSE.

This is your mission if you care to take it.


Code:
Public ST As Double




Sub StartTimer()


  'Unprotect the sheet
  'Unprotect the cells
  'Protect the sheet again
  'Unhide column D
  'Make the cells blank in E12:E21
  
  'Make ST equal to some time in the future (5 minutes)
  ST = Now() + TimeSerial(0, 5, 0)
  'Run the GoTime SUB every second
  Application.OnTime Now() + TimeSerial(0, 0, 1), "GoTime", schedule:=True
  
End Sub


Sub GoTime()
  Dim N As Double
  Dim T As Double
  
  'Make the form visible
  If UserForm1.Visible = False Then
    UserForm1.Show
    UserForm1.Left = 600    UserForm1.Top = 1
    ActiveCell.Select                 'Make the cell have focus, not the form
  End If
  
  N = Now()
  'Debug.Print "ST: " & Format(ST, "hh:mm:ss") & "  Now: " & Format(N, "hh:mm:ss")
  'Remaining time left or zero
  T = Application.Max(ST - N, 0)
  UserForm1.Time_lbl = Format(T, "hh:mm:ss")
  
  'Still time left, call this SUB again
  If T > 0 Then
    Application.OnTime Now() + TimeSerial(0, 0, 1), "GoTime", schedule:=True
  Else
    'No time left, display the form for another 5 seconds
    UserForm1.AllDone_lbl = "All Done!"
    'Unprotect the sheet
    'Protect cells E12:E21
    'Hide Column D
    'Protect the sheet again
    
    Application.OnTime Now() + TimeSerial(0, 0, 5), "CloseForm", schedule:=True
  End If
End Sub


Sub CloseForm()
  Unload UserForm1
  
End Sub
 

David_R

New Member
Joined
Feb 21, 2019
Messages
5
Hi DanteAmor,

thank you for this - it is a great start and works really well at providing the countdown and locking the cells once the countdown is complete.

Could I please ask you to update the code with unhiding Column D when the button is initially clicked? While I can follow pretty much all of your code, I don't know any VBA myself unfortunately.

This would be greatly appreciated.
Thank you
David_R


Try this:



Assign the "Initial" macro to your button

change "abc" by the password of your sheet



Before running the macro, I advise you to try with "00:00:08" seconds to see the operation, when you have it ready, change to "00:10:00" minutes



Put the following code in a module:


Code:
Public ahora
Const pwd = "[B][COLOR=#0000ff]abc[/COLOR][/B]"


Sub [B]Initial[/B]()
    ahora = Now
    ActiveSheet.Unprotect pwd
    Range("F5").Value = TimeValue("[COLOR=#0000ff][B]00:10:01[/B][/COLOR]")
    Range("E12:E21").Locked = False
    ActiveSheet.Protect pwd
    Call Down_Count
End Sub


Sub Down_Count()
    ActiveSheet.Unprotect pwd
    Range("F5").Value = Range("F5").Value - TimeValue("00:00:01")
    ActiveSheet.Protect pwd
    DoEvents
    If Range("F5").Value = 0 Then
        On Error Resume Next
        Application.OnTime EarliestTime:=ahora, Procedure:="Down_Count", Schedule:=False
        On Error GoTo 0
        ActiveSheet.Unprotect pwd
        Range("E12:E21").Locked = True
        Range("F5").Value = TimeValue("[B][COLOR=#0000ff]00:10:00[/COLOR][/B]")
        ActiveSheet.Protect pwd
        MsgBox "Time's Up!"
        Exit Sub
    End If
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Down_Count", Schedule:=True
End Sub
 

David_R

New Member
Joined
Feb 21, 2019
Messages
5
Hi Jeffrey,

Many thanks for your responses. I'm afraid I don't know any VBA myself, but I like your style - teach a man to fish...!

I'm trying to create a little template for a quiz which reveals column D (the questions) when the 'start quiz' button is pressed, and then locks where the user puts in their answers when the countdown is complete. The idea is that because people google nowadays I'll give them 100 questions to answer within a timeframe so even if they google it will hopefully reward the people who already know the answers without having to google. Its just for an office in-house Friday quiz.

Thanks for your help so far, but because I'm a total VBA novice, I'll work with DanteAmor's code for the moment and hopefully get the 'unhide Column D' part added in. Greatly appreciate your time to date.

Thanks
David_R
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
8,900
Office Version
2007
Platform
Windows
Hi DanteAmor,

thank you for this - it is a great start and works really well at providing the countdown and locking the cells once the countdown is complete.

Could I please ask you to update the code with unhiding Column D when the button is initially clicked? While I can follow pretty much all of your code, I don't know any VBA myself unfortunately.

This would be greatly appreciated.
Thank you
David_R
Try this:

Code:
Public ahora
Const pwd = "abc"


Sub Initial()
    ahora = Now
    ActiveSheet.Unprotect pwd
    Range("F5").Value = TimeValue("00:10:01")
    Range("E12:E21").Locked = False
[COLOR=#0000ff]    Columns("D").EntireColumn.Hidden = False[/COLOR]
    ActiveSheet.Protect pwd
    Call Down_Count
End Sub


Sub Down_Count()
    ActiveSheet.Unprotect pwd
    Range("F5").Value = Range("F5").Value - TimeValue("00:00:01")
    ActiveSheet.Protect pwd
    DoEvents
    If Range("F5").Value = 0 Then
        On Error Resume Next
        Application.OnTime EarliestTime:=ahora, Procedure:="Down_Count", Schedule:=False
        On Error GoTo 0
        ActiveSheet.Unprotect pwd
        Range("E12:E21").Locked = True
        Range("F5").Value = TimeValue("00:10:00")
[COLOR=#0000ff]        Columns("D").EntireColumn.Hidden = True[/COLOR]
        ActiveSheet.Protect pwd
        MsgBox "Time's Up!"
        Exit Sub
    End If
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Down_Count", Schedule:=True
End Sub
 

David_R

New Member
Joined
Feb 21, 2019
Messages
5
Hi DanteAmor,

Thanks a million for the updated code - this works well and unhides Column D when the button is clicked.
Two small points I'm finding is as follows:
  • After starting the countdown by pressing the button the user can restart the countdown by pressing the button again (effectively giving themselves more time). Can the button be disabled after it is clicked the first time so that once the countdown is started the time cannot be reset?
  • If the user types into a cell in E12:E21 it pauses the countdown until they come out of that cell. Is it possible for the countdown to continue to run even if the user is typing in one of the E12:E21 cells?

Thanks & regards
David_R




Try this:

Code:
Public ahora
Const pwd = "abc"


Sub Initial()
    ahora = Now
    ActiveSheet.Unprotect pwd
    Range("F5").Value = TimeValue("00:10:01")
    Range("E12:E21").Locked = False
[COLOR=#0000ff]    Columns("D").EntireColumn.Hidden = False[/COLOR]
    ActiveSheet.Protect pwd
    Call Down_Count
End Sub


Sub Down_Count()
    ActiveSheet.Unprotect pwd
    Range("F5").Value = Range("F5").Value - TimeValue("00:00:01")
    ActiveSheet.Protect pwd
    DoEvents
    If Range("F5").Value = 0 Then
        On Error Resume Next
        Application.OnTime EarliestTime:=ahora, Procedure:="Down_Count", Schedule:=False
        On Error GoTo 0
        ActiveSheet.Unprotect pwd
        Range("E12:E21").Locked = True
        Range("F5").Value = TimeValue("00:10:00")
[COLOR=#0000ff]        Columns("D").EntireColumn.Hidden = True[/COLOR]
        ActiveSheet.Protect pwd
        MsgBox "Time's Up!"
        Exit Sub
    End If
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Down_Count", Schedule:=True
End Sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
8,900
Office Version
2007
Platform
Windows
Hi DanteAmor,

Thanks a million for the updated code - this works well and unhides Column D when the button is clicked.
Two small points I'm finding is as follows:
  • After starting the countdown by pressing the button the user can restart the countdown by pressing the button again (effectively giving themselves more time). Can the button be disabled after it is clicked the first time so that once the countdown is started the time cannot be reset?
  • If the user types into a cell in E12:E21 it pauses the countdown until they come out of that cell. Is it possible for the countdown to continue to run even if the user is typing in one of the E12:E21 cells?

Thanks & regards
David_R
I propose the following. When the book is opened a message will appear:

"Instructions: Press OK when you are ready. You will have 10 minutes for the answers."

When they press OK the clock will start.

The button on the sheet is no longer necessary

If they edit a cell, the clock will not stop, when they leave the cell the clock in cell F5 will be updated showing the real time.

Try with this, update the lines in red with your data. Save your workbook, close and open.

Code:
Public ahora, g5, h5, i5
Const pwd = "[COLOR=#ff0000]abc[/COLOR]"           'password sheet
Const wTime = "[COLOR=#ff0000]00:10:00[/COLOR]"    'time for test


Sub Initial()
    ActiveSheet.Unprotect pwd
    
    g5 = Time
    h5 = Time
    i5 = 0
    
    Range("F5").Value = TimeValue(wTime)
    Range("E12:E21").Locked = False
    Columns("D").EntireColumn.Hidden = False
    ActiveSheet.Protect pwd
    ahora = Now
    Call Down_Count
    
End Sub


Sub Down_Count()
    ActiveSheet.Unprotect pwd
    
    i5 = h5 - g5
    Range("F5").Value = TimeValue(wTime) - TimeValue(Format(i5, "hh:mm:ss"))
    h5 = Time
    
    ActiveSheet.Protect pwd
    DoEvents
    If Range("F5").Value <= 0 Then
        On Error Resume Next
        Application.OnTime EarliestTime:=ahora, Procedure:="Down_Count", Schedule:=False
        On Error GoTo 0
        ActiveSheet.Unprotect pwd
        Range("E12:E21").Locked = True
        Range("F5").Value = TimeValue(wTime)
        Columns("D").EntireColumn.Hidden = True
        ActiveSheet.Protect pwd
        MsgBox "Time's Up!"
        Exit Sub
    End If
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Down_Count", Schedule:=True
End Sub


Sub auto_open()
    
    MsgBox "Instructions: Press OK when you are ready. " & vbCr & vbCr & _
           "You will have : " & wTime & " for the answers.", vbInformation & vbOKOnly, "TEST"
           
    Call Initial
End Sub
 

David_R

New Member
Joined
Feb 21, 2019
Messages
5
DanteAmor - thank you so much!

This works really well - it is very much appreciated.

thank you
David


I propose the following. When the book is opened a message will appear:

"Instructions: Press OK when you are ready. You will have 10 minutes for the answers."

When they press OK the clock will start.

The button on the sheet is no longer necessary

If they edit a cell, the clock will not stop, when they leave the cell the clock in cell F5 will be updated showing the real time.

Try with this, update the lines in red with your data. Save your workbook, close and open.

Code:
Public ahora, g5, h5, i5
Const pwd = "[COLOR=#ff0000]abc[/COLOR]"           'password sheet
Const wTime = "[COLOR=#ff0000]00:10:00[/COLOR]"    'time for test


Sub Initial()
    ActiveSheet.Unprotect pwd
    
    g5 = Time
    h5 = Time
    i5 = 0
    
    Range("F5").Value = TimeValue(wTime)
    Range("E12:E21").Locked = False
    Columns("D").EntireColumn.Hidden = False
    ActiveSheet.Protect pwd
    ahora = Now
    Call Down_Count
    
End Sub


Sub Down_Count()
    ActiveSheet.Unprotect pwd
    
    i5 = h5 - g5
    Range("F5").Value = TimeValue(wTime) - TimeValue(Format(i5, "hh:mm:ss"))
    h5 = Time
    
    ActiveSheet.Protect pwd
    DoEvents
    If Range("F5").Value <= 0 Then
        On Error Resume Next
        Application.OnTime EarliestTime:=ahora, Procedure:="Down_Count", Schedule:=False
        On Error GoTo 0
        ActiveSheet.Unprotect pwd
        Range("E12:E21").Locked = True
        Range("F5").Value = TimeValue(wTime)
        Columns("D").EntireColumn.Hidden = True
        ActiveSheet.Protect pwd
        MsgBox "Time's Up!"
        Exit Sub
    End If
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Down_Count", Schedule:=True
End Sub


Sub auto_open()
    
    MsgBox "Instructions: Press OK when you are ready. " & vbCr & vbCr & _
           "You will have : " & wTime & " for the answers.", vbInformation & vbOKOnly, "TEST"
           
    Call Initial
End Sub
 

Forum statistics

Threads
1,082,380
Messages
5,365,124
Members
400,824
Latest member
Themilkybarkid

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top