excel sheet protection

[Ron99]

Hi,

I have added few buttons in a spreadsheet which is coded with macros, anyone who tries to click that button should get a prompt " enter password", so that only few people who have permissions only can operate that button. Is this possible ?

I have protected the worksheet, but when the button is clicked they get debug message, which I dont want to execute, rather clicking on the button should give a prompt " enter password "

Let me know if further details are required.

Thank you

 

[Trevor G]

You need to enter some kind of inputbox message asking for the password, if entered correct they can edit otherwise message with no permission to carry on something like this

Sub ProtectOff()
Dim strPassword As String
strPassword = "Enter"
If InputBox("Please Enter Password to continue") = strPassword Then
    ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False

Else
MsgBox "Incorrect Password please contact the Administrator to gain entry"
Exit Sub
End If
End Sub

 

[Ron99]

Hi,

There is already this code which is existing on this sheet

Sub Update_activity()
Dim Wsht As Worksheet
Dim Rng As Range, Dn As Range, n As Long
Dim Sh As Integer
Dim Col As Integer
Dim Temp As Variant
n = 1
Temp = Range("A1:Q3")
ActiveSheet.UsedRange.ClearContents
Range("A1:Q3") = Temp
ReDim ray(1 To Rows.Count, 1 To Worksheets.Count + 4)
ray(1, 2) = "SL#": ray(1, 3) = "Activity": ray(1, 4) = "Start Date"
ray(1, 5) = "End Date"
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Wsht In Worksheets
If Wsht.Name <> "GCS Activities" And Wsht.Name <> "Pending Activities" And Wsht.Name <> "Button sheet" And Wsht.Name <> "INSTRUCTION" Then
Sh = Sh + 1
ray(1, Sh + 4) = Wsht.Name
With Wsht
Set Rng = .Range(.Range("B2"), .Range("B" & Rows.Count).End(xlUp))
End With
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
n = n + 1
.Add Dn.Value, n
ray(n, 1) = n - 1
ray(n, 2) = Dn
ray(n, 3) = Dn(, 2)
ray(n, 4) = Dn(, 3)
ray(n, Sh + 4) = Dn(, 4)
Else
ray(.Item(Dn.Value), Sh + 4) = Dn(, 4)
End If
Next Dn
End If
Next Wsht
End With
With Sheets("GCS Activities")
.Range("A4").Resize(n, Sh + 4) = ray
End With
Range("B4:C4").Select
Selection.Cut
Range("A4").Select
ActiveSheet.Paste
Range("C4").Select
ActiveCell.FormulaR1C1 = "Start Date"
With ActiveCell.Characters(Start:=1, Length:=10).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("D4").Select
ActiveCell.FormulaR1C1 = "Due Date"
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Rows("5:5").Select
Selection.Delete Shift:=xlUp
Range("A5").Select
ActiveCell.FormulaR1C1 = "1"
Range("A6").Select
ActiveCell.FormulaR1C1 = "2"
Range("A5:A6").Select
Selection.AutoFill Destination:=Range("A5:A13")
Range("A5:A13").Select
Range("C4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("D4").Select
Selection.Copy
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A4:B4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A4").Select
End Sub


where do you want me to add the code which you have given me ?

The above code was given by one the guys from mr excel, I dont know VBA, if you can help me adding the code which you have given me to the code above...it would be great

 

[Trevor G]

Try adding the code near the top as follows, I have changed my first sample slightly as you have a lot of code to run.

Add the first part near the top of your code as far as I have indicated in Red, then add your code and after it has done the code add the End If at the end, but before the End Sub.

Sub ProtectOff()
Dim strPassword As String
strPassword = "Enter"
If InputBox("Please Enter Password to continue") <> strPassword Then
MsgBox "Incorrect Password please contact the Administrator to gain entry"
Exit Sub

Else
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
[COLOR=red]'Add your code here
[/COLOR]End If
End Sub

 

[Ron99]

Superb!!...Thanx mate!...it worked

 

[Ron99]

Hi,

I have one small problem to be rectified. I have a master file where all the Pending task is identified. Now according to the code, it identifies the word "Pending" and executes the code. I have changed the word "Pending" to "P", I am unable to execute the code, here is the code

Sub Ron99()
Dim strPassword As String
strPassword = "Enter"
If InputBox("Please Enter Password to continue") <> strPassword Then
MsgBox "Incorrect Password please contact the Administrator to gain entry"
Exit Sub
Else
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
Dim LR As Long, _
LC As Long, _
dWs As Worksheet, _
sWs As Worksheet, _
rowx As Long, _
Rng As Range, _
rng1 As String

Sheets("GCS Activities").Select
Set sWs = ActiveSheet
Sheets.Add After:=sWs
Set dWs = ActiveSheet
dWs.Name = "Pending Task"
rowx = 2
Application.ScreenUpdating = False
LR = sWs.Range("A" & Rows.Count).End(xlUp).Row
LC = sWs.Cells(1, Columns.Count).End(xlToLeft).Column
dWs.Cells(1, 1).Value = "Name"
dWs.Cells(1, 2).Value = "Activity"
dWs.Cells(1, 3).Value = "Due Date"
With sWs.Range(sWs.Cells(5, 5), sWs.Cells(LR, LC))
Set Rng = .Find("Pending", LookIn:=xlValues)
If Not Rng Is Nothing Then
rng1 = Rng.Address
Do
dWs.Cells(rowx, 1).Value = sWs.Cells(4, Rng.Column).Value
dWs.Cells(rowx, 2).Value = sWs.Cells(Rng.Row, 2).Value
dWs.Cells(rowx, 3).Value = sWs.Cells(Rng.Row, 4).Value
rowx = rowx + 1
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> rng1
End If
End With
dWs.Range("A:C").Sort Key1:=dWs.Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Application.ScreenUpdating = True
Application.StatusBar = False
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End If
MsgBox ("Please proceed with data sorting !!")
End Sub

The above word Pending which I have marked in red, I changed it to "P", it doesnt work, I think there should be somewhere else I need to correct, I need your help.