Password protect macro at certain time period

[a_27826]

Can I password protect the below macro to run between 8.30am and 6pm?

with a message like "Please enter password to refresh the pivot tables between 8.30am and 6.00pm"

But however the I need macro to run without the need of the password between 6.01pm and 8.29am.

Sub AllSheetsRefresh()

Application.ScreenUpdating = False

For Each Worksheet In Worksheets
Worksheet.Unprotect Password:="mypassword"
Next Worksheet

For Each PivotCache In ActiveWorkbook.PivotCaches
PivotCache.Refresh
Next

For Each Worksheet In Worksheets
Worksheet.Protect Password:="mypassword", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
UserInterfaceOnly:=True, _
AllowFormattingCells:=False, _
AllowFormattingColumns:=False, _
AllowFormattingRows:=False, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=False, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=False, _
AllowSorting:=False, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True

Next Worksheet

Application.ScreenUpdating = True

End Sub

 

[Explore VBA]

hi a_27826, i think the best way and to keep it simple will be to keep the sheets protected using your macro. Assign 1 button each above the pivot table so that your macro will unprotect that current sheet and do all the required tesk including refresh and protect it back.
Another option will be to use Application.Ontime method...Application.OnTime Method (Excel)

 

[a_27826]

The reason i want this is because the source file is external sql.....its a program.......when the users refresh the pivot table, the program data feeders at the main office are unable use the program because its tables are being used by the pivot table refreshers.

so i want to restrict the refresh of the pivot tables between 8.30am to 6.00pm (the peak time period for data entry in the program).

i am really interested in your suggestion of Application.Ontime method but i am not so good at vba.

can help me to add the Application.Ontime in the existing code about the time period restriction?

that is, password prompt between 8.30am and 6.00pm and no password prompt between other time period.

 

[Explore VBA]

hi a_27826, please visit the below link for deme file i created for you. I have created a temp link for your ref. Please download by clicking on [time sc] button there..

https://explorevba.wordpress.com/20...ecific-time-else-enter-password-and-continue/

Regards
Explore VBA

 

[a_27826]

Thanx for creating the file for me but when put the password "mypassword", i get "Incorrect password" reply.

any idea what is wrong?

 

[a_27826]

Ok i got it.....

the password is "ok"

 

[Explore VBA]

there you go. Unfortunately I couldnt upload xlsm file due to the blog limitations. anyways enjoy.

 

[royUK]

You simply need to add an inputbox requesting a password

Option Explicit
Sub AllSheetsRefresh()
    Const PW As String = "mypassword"
    Dim sPW As String
    Dim oWS As Worksheet
    Dim PT As PivotCache


    If TimeValue(Now) >= "08:30" Or TimeValue(Now) <= "06:00" Then
        sPW = Application.InputBox("Please enter password to refresh the pivot tables between 8.30am and 6.00pm")
        If sPW <> PW Then GoTo exit_proc
    End If




    For Each oWS In ThisWorkbook.Worksheets
        oWS.Unprotect Password:=PW
    Next oWS


    For Each PT In ActiveWorkbook.PivotCaches
        PT.Refresh
    Next PT


    For Each oWS In Worksheets
        oWS.Protect Password:=PW, _
                    DrawingObjects:=True, _
                    Contents:=True, _
                    Scenarios:=True, _
                    UserInterfaceOnly:=True, _
                    AllowFormattingCells:=False, _
                    AllowFormattingColumns:=False, _
                    AllowFormattingRows:=False, _
                    AllowInsertingColumns:=False, _
                    AllowInsertingRows:=False, _
                    AllowInsertingHyperlinks:=False, _
                    AllowDeletingColumns:=False, _
                    AllowDeletingRows:=False, _
                    AllowSorting:=False, _
                    AllowFiltering:=True, _
                    AllowUsingPivotTables:=True


    Next oWS


    Exit Sub


exit_proc:
    MsgBox "Wrong password or no password entered", vbCritical, "Closing"


End Sub

 

[a_27826]

Hi royUK,

The code is asking for password even its before 08.30am or after 06.00pm........

you can verify by interchanging > with < and vice versa

1. I tried to change "06:00" to "18:00" but no luck
2. I tried to change "08:30" and "06:00" to "08:30 AM" and "06:00 PM", it doesn't work either
3. I tried to change Or with And and still no luck
4. I tried to change "08:30" and "06:00" to ("08:30") and ("06:00"), it doesn't work either

Can you have a look at it?

 

[royUK]

I've changed the code slightly and this works for me

 If TimeValue(Now) >= "08:30:00" And TimeValue(Now) < "18:00:00" Then
        sPW = Application.InputBox("Please enter password to refresh the pivot tables between 8.30am and 6.00pm")
        If sPW <> PW Then GoTo exit_proc
    End If