Multifunction Button

D

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
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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


DanteAmor said:
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
Click to expand...
 
Upvote 0
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
 
Upvote 0
David_R said:
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
Click to expand...

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
 
Upvote 0
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




DanteAmor said:
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
Click to expand...
 
Upvote 0
David_R said:
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
Click to expand...

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
 
Upvote 0
DanteAmor - thank you so much!

This works really well - it is very much appreciated.

thank you
David


DanteAmor said:
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
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
VBA button click from within a macro
Replies
2
Views
470
Chris_yorks
C
B
  • Question
Event code to give message box and change color of auto-shape
Replies
4
Views
122
bh24524
B
E
  • Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
265
offthelip
O
M
  • Question
Insert merged row into Excel, with duplication of the row(s) formatting above, using Command Button
Replies
1
Views
367
sxhall
S
B
  • Solved
Shift up values to fill in blank cells
Replies
2
Views
513
bujubenji
B

Forum statistics

Threads
1,214,375
Messages
6,119,167
Members
448,870
Latest member
max_pedreira

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top