VBA to require password to filter

[gmittar]

Hi All,

I have a simple sheet of names and roles that I need to send out to about 60 different people. The sheet has all data filtered out, and the recipient selects their organization from a drop down filter, which shows their portion of the sheet. This all works well as is.

What I would like to do is to protect the sheet so that when they select an org from the dropdown, they are prompted for a password. Further, I would like this password to be unique to their org. So I'd like to have a list of orgs and their corresponding passwords that I will superhide. So, select Org #16 , require password #16 .

Any ideas about how to accomplish this?

Thank you in advance

 

[gmittar]

This might be a better illustration of what i'm trying to do. The below screen grab (I don't have attach permissions) represents both tabs that I have, but ultimately, the Org/PW lists will be on a superhidden tab.

I'm planning to have the data on the data tab completely hidden (I have that part worked out), with the user selecting their org from the drop down up top. When they select their org, I want to prompt them for a password, which will then compare the selected org to the list and then check the corresponding password. If the password matches, the filter will show the data for the org they've selected. If not, it will give an error message.

I know this is possible as I've found similar code via google, but I'm just not good enough to do the rework. I apologize for the plain paste, I haven't yet figured out how to property attach items here. Any help is appreciated.

Org name	PW			Org 1
Org 1	42
Org 2	31			Org	Jan	Feb	Mar	Apr	May	Jun
Org 3	79			Org 1	92	97	54	64	99	11
Org 4	22			Org 2	87	65	31	1	98	88
Org 5	6			Org 3	69	100	57	6	10	9
Org 6	44			Org 4	73	80	82	50	80	78
Org 7	47			Org 5	28	97	73	84	57	48
Org 8	7			Org 6	37	46	36	68	32	47
Org 9	20			Org 7	34	79	83	22	43	56
Org 10	2			Org 8	55	62	51	33	42	92
				Org 9	12	90	68	64	92	28
				Org 10	54	72	96	16	35	2

<colgroup><col width="64" span="11" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[mumps]

This forum doesn't allow the attachment of files. If you want to post your file, you could upload a copy of your file which includes the macros you are currently using, to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do using a few examples from your data and referring to specific cells, rows, columns and worksheets. If the workbook contains confidential information, you could replace it with generic data.

 

[gmittar]

Thanks for the info. Attached is a sample file with the macros that I'm currently using to filter the data based on the dropdown.

I would like a password prompt to pop up when the filter is used, and then if the password matches per the org list, filter the data.

https://sagehospitalityllc.box.com/s/jtabpqvqpnwwb816tezusozfbvcablfm

Thank you in advance.

 

[mumps]

Start by unlocking cell A1 in the "Data" sheet. Hide all the rows from row 2 down. Protect the sheet using the password "MyPassword". Copy and paste the macro below into the worksheet code module. Do the following: right click the tab for your "Data" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. You can change the password to one of your choosing. If you do, then change all occurrences of "MyPassword" in the macro to match the one you chose. Close the code window to return to your sheet. Make a selection in the drop down list in cell A1.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim lastRow As Long, pw As Range, response As String
    lastRow = Columns(1).Find(what:="*", after:=Cells(Rows.Count, "A"), LookIn:=xlFormulas, lookat:=xlPart, searchdirection:=xlPrevious).Row
    response = InputBox("Please enter your password.")
    If response = "" Then
        MsgBox ("You have not entered a password.")
        Application.ScreenUpdating = True
        Exit Sub
    Else
        Set pw = Sheets("Users").Range("A:A").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
        If Not pw Is Nothing And pw.Offset(0, 1) = response Then
            ActiveSheet.Unprotect Password:="MyPassword"
            Range("A3:G" & lastRow).AutoFilter Field:=1, Criteria1:=pw
            ActiveSheet.Protect Password:="MyPassword", DrawingObjects:=True, Contents:=True, Scenarios:=True
            ActiveSheet.EnableSelection = xlUnlockedCells
        Else
            MsgBox ("You have entered an invalid password.")
            Application.ScreenUpdating = True
            Exit Sub
        End If
    End If
    Application.ScreenUpdating = True
End Sub

 

[gmittar]

Thanks Mumps, that works very well! Appreciate the help

 

[mumps]

You are very welcome.

 

[gmittar]

Hi mumps,

One thing I'd like to add to this macro. If I want to show all the orgs, how do I accomplish that?

Thanks!

 

[mumps]

Click here to download your file.

I have changed the Data Validation formula to refer to range A2:A12 in the Users sheet and have added "All" to the drop down list. When you choose "All" from the dropdown list, enter "ShowAll" to the prompt asking for the password. You can change the password to something of your choosing by changing it in the macro.

 

[gmittar]

Works great, thanks again!