How to password protect a MACRO and set a specific cell value

Adendum

New Member
Joined
Feb 15, 2021
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
Hi Gurus,

I have a macro (courtesy of the wonderful forum) within a workbook that is used once a month to clear out all the data from specific cells so we can set up a new empty workbook for the next month.

The workbook contains several macros that users can and will use on a daily basis. Obviously I don't want any one running that macro accidentally during the month and, ideally, I would prefer the macro to only be run after entering a password (that only I will know). At the moment I am manually creating this macro at the time I want to do the clear down but if I can protect the macro I can keep it in the workbook.

Q1: Is that possible and how can I achieve this?

My cleardown macro deletes content from cells A2:C2000 in multiple sheets, with some excluded. However in column D2 to D2000 I have data validation cells with values set from the previous month. I would like to reset all D2:D2000 cells to the first in the list. The list is from another sheet called "Outcomes" and looks like this ='OUTCOMES'!$A$2:$A$12

Q2: If this is possible can I add this feature to the VBA below?

VBA Code:
Sub Clear_Range()
'Clear off all data from sheets 01-31
Application.ScreenUpdating = False
Dim ans As Long
ans = ThisWorkbook.Sheets.Count
Dim i As Long

For i = 1 To ans
    If Sheets(i).Name <> "OUTCOMES" And Sheets(i).Name <> "Raw Data" And Sheets(i).Name <> "Action" And Sheets(i).Name <> "With List" Then Sheets(i).Range("A2: C2000").ClearContents
Next
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Try this for the Password requirement
VBA Code:
Sub Clear_Range()
'Clear off all data from sheets 01-31
Application.ScreenUpdating = False
Dim ans As Long, Pwd As String, chk As String
Pwd = "your password"
chk = InputBox("Please Insert you Password", "Password Required", vbOK)
If chk <> Pwd Then
MsgBox "Sorry, this Password is Invalid !!"
Exit Sub
End If
ans = ThisWorkbook.Sheets.Count
Dim i As Long

For i = 1 To ans
    If Sheets(i).Name <> "OUTCOMES" And Sheets(i).Name <> "Raw Data" And Sheets(i).Name <> "Action" And Sheets(i).Name <> "With List" Then Sheets(i).Range("A2: C2000").ClearContents
Next
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Other ideas:

It sounds like you are really trying to prevent accidental removal of data but of course if you put the password in the code as suggested by Michael, that password would be obtainable by other users if they want and know how. Of course an option to prevent that would be to password protect the vba as well.

If it is just accidental erasure that you are worried about and you trust the others you could take an approach like this which means to delete that data they have to both run the macro and confirm deletion.

VBA Code:
Sub Sample_1()
  Dim Resp As VbMsgBoxResult
  
  Resp = MsgBox("Are you sure that you want to delete all data and start a new month?", vbYesNoCancel)
  If Resp = vbYes Then
    'Put all your delete code here
  End If
End Sub

Another approach that does not require a password or manual confirmation is to only allow the code if it is you logged in to the computer.
This idea included below but I also noted you code comment "Clear off all data from sheets 01-31". If that means the sheets in question are named "01", "02", ..., "31" and all 31 of those sheets always exist, then you might be able to use something like this. It doesn't require a password but it will not delete anything if other users run it

VBA Code:
Sub Clear_Range_v2()
  'Clear off all data from sheets 01-31
  Dim i As Long
  
  If Environ("username") = "put your Windows login name here" Then
    Application.ScreenUpdating = False
    For i = 1 To 31
        With Sheets(Format(i, "00"))
          .Range("A2: C2000").ClearContents
          .Range("D2:D2000").Value = Sheets("OUTCOMES").Range("A2").Value
        End With
    Next i
    Application.ScreenUpdating = True
  End If
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,881
Messages
6,175,159
Members
452,615
Latest member
bogeys2birdies

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