Place this code in the VBA module for the worksheet you would like to
restrict and give it a try (needless to say: for this password
strategy to be bullet-proof you would have to password-protect the VBA
project, so that none uf your users can have access to the passwords):
Const RANGE1_PWD = "abc"
Const RANGE2_PWD = "def"
Const RANGE3_PWD = "xyz"
Const RESTRICTED_RANGE1 = "A1:K15"
Const RESTRICTED_RANGE2 = "C3:D6 "
Const RESTRICTED_RANGE3 = "D5:E8"
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static b_UserPassedAuthentication(2) As Boolean
If Not Intersect(Target, Range(RESTRICTED_RANGE1)) Is Nothing Then
If Not Intersect(Target, Range(RESTRICTED_RANGE2)) Is Nothing
Then
If b_UserPassedAuthentication(1) Then Exit Sub
b_UserPassedAuthentication(1) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE2), RANGE2_PWD)
ElseIf Not Intersect(Target, Range(RESTRICTED_RANGE3)) Is
Nothing Then
If b_UserPassedAuthentication(2) Then Exit Sub
b_UserPassedAuthentication(2) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE3), RANGE3_PWD)
Else
If b_UserPassedAuthentication(0) Then Exit Sub
b_UserPassedAuthentication(0) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE1), RANGE1_PWD)
End If
ElseIf Not Intersect(Target, Range(RESTRICTED_RANGE2)) Is Nothing
Then
If Not Intersect(Target, Range(RESTRICTED_RANGE1)) Is Nothing
Then
If b_UserPassedAuthentication(0) Then Exit Sub
b_UserPassedAuthentication(0) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE1), RANGE1_PWD)
ElseIf Not Intersect(Target, Range(RESTRICTED_RANGE3)) Is
Nothing Then
If b_UserPassedAuthentication(2) Then Exit Sub
b_UserPassedAuthentication(2) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE3), RANGE3_PWD)
Else
If b_UserPassedAuthentication(1) Then Exit Sub
b_UserPassedAuthentication(1) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE2), RANGE2_PWD)
End If
ElseIf Not Intersect(Target, Range(RESTRICTED_RANGE3)) Is Nothing
Then
If Not Intersect(Target, Range(RESTRICTED_RANGE1)) Is Nothing
Then
If b_UserPassedAuthentication(0) Then Exit Sub
b_UserPassedAuthentication(0) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE1), RANGE1_PWD)
ElseIf Not Intersect(Target, Range(RESTRICTED_RANGE2)) Is
Nothing Then
If b_UserPassedAuthentication(1) Then Exit Sub
b_UserPassedAuthentication(1) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE2), RANGE2_PWD)
Else
If b_UserPassedAuthentication(2) Then Exit Sub
b_UserPassedAuthentication(2) = UserAuthenticatedForRange
(Range(RESTRICTED_RANGE3), RANGE3_PWD)
End If
End If
End Sub
Function UserAuthenticatedForRange(r As Range, rPwd As String) As
Boolean
If InputBox("Enter the password required to edit cells in range "
& r.Address) = rPwd Then
UserAuthenticatedForRange = True
Else
MsgBox "Incorrect password!", vbExclamation
UserAuthenticatedForRange = False
End If
End Function
This may not be the most elegant code, but it seems to do the job.
Hope this helped,
Rolf
On Oct 30, 3:45 am, DEBASHIS BANERJEE <debashis....@gmail.com> wrote:
> Dear Friends,
>
> I need help in writing macro to provide multiple protection of a work
> sheet .
>
> ie two or three passward can be provided in a single work sheet and
> every user would be restricted to edit the area where he is not
> permitted to edit .
>
> kindly help .
>
> thanks and regards .
>
> debashis.
--~--~---------~--~----~------------~-------~--~----~
----------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
<><><><><><><><><><><><><><><><><><><><><><>
HELP US GROW !!
We reach over 6,500 subscribers worldwide and receive many nice notes about the
learning and support from the group. Our goal is to have 10,000 subscribers by
the end of 2009. Let friends and co-workers know they can subscribe to group at
http://groups.google.com/group/excel-macros/subscribe
-~----------~----~----~----~------~----~------~--~---
