Filtered Data Validation list (maybe VBA)

  • Thread starter Thread starter janetisaac
  • Start date Start date
J

janetisaac

I have a few lists used for data validation (drop downs). I am tryin
to filter the list based on what is entered in a specific cell (D3).
do not want the entire list to show, only the ones that are specific t
the entry marked in cell D3.

My list is set up as a crosstab:
column listing projects, tasks and rates
row listing employees
x where the employee is associated with project, task or rate

When the employee name is chosen in D3
I want to look up the three lists for data validation based on whic
are associated with this employee.

I really appreciate your help. I am familiar with VBA, but don't eve
know where to get started. Not sure if I should set this up a littl
different. Any advice will be greatly appreciated.

Thank you.

Jane
 
Thanks Tom

I've been researching this idea and seems like more work than using
VBA statement. It seems as if I would have to create three named list
for each employee: one for their projects, one for their tasks, an
one for their rate. We currently only have 30 employees, but when w
start adding 50 more employees and more projects and more tasks...I
seems that this method may get too complicated (to keep updating th
validation lists). What do you think
 
Why would you have three lists for each employee. It seems that project,
task and rate would always need to stay together. I wouldn't want someone
to select project 2, a task from project 5, and a rate from project 6???

Anyway, you can apply an autofilter to your table, and copy the visible data
to another location and apply it to the data validation list.

You can get the visible cells with

if activesheet.AutofilterMode then AutofilterMode = False
range("A10").CurrentRegion.Autofilter Field:=1, _
Critiera:="="&Range("D3")
rw = 9
set rng ActiveSheet.Autofilter.Range.Columns(1).Cells
if rng.count = 1 then '
' no records for this employee
else
set rng1 = rng.offset(1,0).Resize(rng.rows.count-1)
set rng1 = rng1.specialcells(xlvisible)
for each cell in rng1
rw = rw + 1
cells(rw,"M").Resize(1,3).Value = cell.Resize(1,3)
next
End if
 
The projects, tasks and rates are not related in any way except to th
employee.
i.e. Projects: 1, 2, 3, 4...;
Tasks: Programmer, Clerical, Electrical Engineer, Management;
Rate: Salary, Salary Holiday, Hourly, Hourly Holiday
An employee can work as management on many different Projects.


My list is setup as one long list down columns A&B
Column A, Column B
Project, Project1
Project, Project2
Project, Project3
Task, Programmer
Task, Clerical
Task, Management
Rate, Salary
Rate, Hourly
Rate, Salary Holiday
Rate, Hourly Holiday

Emp1 Emp2 Emp3
Proj Proj1 x x
Proj Proj2 x x
Proj Proj3 x x
Task Clerical x x
Task Programmer x x
Task Management x x
Rate Salary x
Rate Salary Holiday x
Rate Hourly x x
Rate Hourly Holiday x x


Row 1 includes all employees:
There is an "x" where the employee is on a project or has a specifi
task association. I personally have 6 projects and 4 task
(Librarian, Admin support...)

I thought this layout was best based on the fact that we will be addin
new projects and employees all the time. (Easier to manage)

I'm evaluating different layouts and tryign different programs to se
if I can get it to work. Your code looked OK, but I got an error o
"set rng ActiveSheet.Autofilter.Range.Columns(1).Cells" and I am no
sure how to start this code. I only want the lists to change when cel
D3 changes. I don't want it to run everytime there is a change on th
sheet.

I appreciate all your time. If this gets to be too much, please do no
hesitate to stop me at any point.

Jane
 
The way you have you data laid out, you pretty much are going to just loop
down

You don't say where it starts, so assume cell A20 (Employee header in row
19)

combobox1 contains employee ID matching the headers in row 19 (starting in
column C)
combobox2 will contain project choices
combobox3 will contain task choices
combobox4 will contain rate choices


the macro fires when an employee is selected in combobox1. Code goes in the
sheet module of the sheet with the comboboxes.

Private Sub ComboBox1_Change()
Dim res As Variant
Dim rng1 As Range
Dim rng As Range, cell As Range
With Me
.ComboBox2.Clear
.ComboBox3.Clear
.ComboBox4.Clear
End With

res = Application.Match(Range("D3"), Rows(19), 0)
If Not IsError(res) Then
Set rng1 = Rows(19).Cells(1, res)
Set rng = Range(Cells(20, 1), Cells(20, 1).End(xlDown))
For Each cell In rng
If Not IsEmpty(Cells(cell.Row, rng1.Column)) Then
If Cells(cell.Row, 1).Value = "Proj" Then
ActiveSheet.ComboBox2.AddItem Cells(cell.Row, 2).Value
ElseIf Cells(cell.Row, 1).Value = "Task" Then
ActiveSheet.ComboBox3.AddItem Cells(cell.Row, 2).Value
Else
ActiveSheet.ComboBox4.AddItem Cells(cell.Row, 2).Value
End If
End If
Next
End If

End Sub

Given the stated assumptions and your sample data, the above worked fine for
me.
 
Works great. Love the code. Thank you sooooo much. Looks a lo
cleaner than (and actually works) the code I came up with.

My lists are on a different sheet, but I can probably fit that in thi
code. Boy, I have a lot to learn. I have taught the MS programs fo
over 10 years to end users. I have been playing with VBA in Excel an
Access for about 3 years. No formal programming training. Bet yo
couldn't figure that out.

The only problem I encounter now is that I am using a data validatio
lists for the project, task and pay rate, not combo boxes.

Reason: They will be filling this out for two weeks at a time and wil
have multiple projects, tasks and sometimes pay rates for that tim
frame.

I was using cell B8:B27 for project fill ins, D8:D27 for task fill ins
and F8:F27 for pay rate.

If you have any suggestions, I'd be happy to try them out
 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim res As Variant
Dim rng1 As Range, rng2 as Range
Dim rng As Range, cell As Range
Dim sh as Worksheet
Set sh = Worksheets("DataTable")
On Error goto ErrHandler
Application.EnableEvents = False
if Target.Address <> "$D$3" then exit sub
With Me
.range("B8:B27").ClearContents
.range("D8:D27").ClearContents
.range("D8:D27").ClearContents
End With

res = Application.Match(Range("D3"), sh.Rows(19), 0)
If Not IsError(res) Then
Set rng1 = sh.Rows(19).Cells(1, res)
Set rng = sh.Range(sh.Cells(20, 1), sh.Cells(20, 1).End(xlDown))
For Each cell In rng
If Not IsEmpty(sh.Cells(cell.Row, rng1.Column)) Then
If sh.Cells(cell.Row, 1).Value = "Proj" Then
if isempty(Range("B8")) then
set rng2 = Range("B8")
elseif isempty(Range("B9")) then
set rng2 = Range("B9")
else
set rng2 = Range("B8").End(xldown)(2)
end if
rng2 = sh.Cells(cell.row,2).Value

ElseIf Cells(cell.Row, 1).Value = "Task" Then
if isempty(Range("D8")) then
set rng2 = Range("D8")
elseif isempty(Range("D9")) then
set rng2 = Range("D9")
else
set rng2 = Range("D8").End(xldown)(2)
end if
rng2 = sh.Cells(cell.row,2).Value

Else
if isempty(Range("F8")) then
set rng2 = Range("F8")
elseif isempty(Range("F9")) then
set rng2 = Range("F9")
else
set rng2 = Range("F8").End(xldown)(2)
end if
rng2 = sh.Cells(cell.row,2).Value
End If
End If
Next
End If
ErrHandler:
Application.EnableEvents = True
End Sub

I haven't tested this, but you should be able to hammer it into a solution.
 
Set rng = sh.Range(sh.Cells(20, 1), sh.Cells(20, 1).End(xlDown))

rng is returning nothin
 
Set rng = sh.Range(sh.Cells(20,1), sh.Cells(20,1).End(xlDown)) return
nothing

I tried to separate it

Set cl1 = sh.Cells(20, 1) returns Project
Set cl2 = sh.Cells(20, 1).End(xlDown) returns PayRate
Set rng = sh.Range(cl1, cl2) still returns nothing

:confused
 
Using the same layout as the original code, with your table data starting in
A20, headers in row 19, and your data now on a sheet named DataTable, it
would return the same as it did last night. Alter to match your layout or
reproduce the assumed layout.

anyway, I reset up your table as above (assume B8:B27, etc, refers to the
sheet that contains the data validation dropdowns. )

This code has two typos corrected (but they wouldn't affect the the problem
you state). The code is in the sheet module of the sheet where D3 will hold
the employee ID.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim res As Variant
Dim rng1 As Range, rng2 As Range
Dim rng As Range, cell As Range
Dim sh As Worksheet
Set sh = Worksheets("DataTable")
On Error GoTo ErrHandler
Application.EnableEvents = False
If Target.Address <> "$D$3" Then Exit Sub
With Me
.Range("B8:B27").ClearContents
.Range("D8:D27").ClearContents
.Range("F8:F27").ClearContents
End With

res = Application.Match(Range("D3"), sh.Rows(19), 0)
If Not IsError(res) Then
Set rng1 = sh.Rows(19).Cells(1, res)
Set rng = sh.Range(sh.Cells(20, 1), sh.Cells(20, 1).End(xlDown))
For Each cell In rng
Debug.Print "->" & sh.Cells(cell.Row, 1); "<-"
If Not IsEmpty(sh.Cells(cell.Row, rng1.Column)) Then
If sh.Cells(cell.Row, 1).Value = "Proj" Then
If IsEmpty(Range("B8")) Then
Set rng2 = Range("B8")
ElseIf IsEmpty(Range("B9")) Then
Set rng2 = Range("B9")
Else
Set rng2 = Range("B8").End(xlDown)(2)
End If
rng2 = sh.Cells(cell.Row, 2).Value

ElseIf sh.Cells(cell.Row, 1).Value = "Task" Then
If IsEmpty(Range("D8")) Then
Set rng2 = Range("D8")
ElseIf IsEmpty(Range("D9")) Then
Set rng2 = Range("D9")
Else
Set rng2 = Range("D8").End(xlDown)(2)
End If
rng2 = sh.Cells(cell.Row, 2).Value

Else
If IsEmpty(Range("F8")) Then
Set rng2 = Range("F8")
ElseIf IsEmpty(Range("F9")) Then
Set rng2 = Range("F9")
Else
Set rng2 = Range("F8").End(xlDown)(2)
End If
rng2 = sh.Cells(cell.Row, 2).Value
End If
End If
Next
End If
ErrHandler:
Application.EnableEvents = True
End Sub

worked fine for me.
 
Thank you very much Tom. I will play with the code and see what it wil
do.

I think we may be thinking backwards from each other.

"...with your table data starting in A20, headers in row 19, and you
data now on a sheet named DataTable,..."

My data validation cells are on the same sheet with the Employee Nam
and the Table of values (who is allowed what projects, tasks...) is o
DataTable.

I wanted the code to fill the Employee name sheet, cells B8:B7 wit
data validation including the projects alloted to them on teh Dat
Table sheet.

Are we thinking the same
 
Sheet Name: Employee_Name (actual name is irrelevant)
Cell D3 is a data validation cell with a list of employee identifiers
(matching those in what I describe as row 19: Emp1, Emp2, Emp3)
3 other cells have data validation for Project , Task and Rate
B8:B27 is the source range for the data validation for Project
D8:D27 is the source range for the data validation for Task
F8:F27 is the source range for the data validation for Rate

The code is placed in the sheet code of this sheet, so when a selection is
made in the dropdown of D3, the B8:B27, D8:D27, F8:F27 values are filled
based on the selection (and the related dropdowns reflect that selection).

-----------------------------

Sheet Name: DataTable
C19: Emp1
D19: Emp2
E19: Emp3
A20: Proj
A21: Proj
A22: Proj
A23: Task
A24: Task
A25: Task
A26: Rate
A27: Rate
A29: Rate
A30: Rate
corresponding entries in Column B starting in B20

Proj1
Proj2
Proj3
Clerical
Programmer
Management
Salary
SalaryHoliday
Hourly
HourlyHoliday


Cells C20 to E30, starting in C20 contains x's in some cells to indicate
employee "allows"

It sounds like we are describing the same, but it works fine for me.
 
Everything working up to this point.

I can't get the code to select the new Project (on sheet 3, a1 throug
a?) and give it a range name so that it validation may be set o
Employe sheet in cells b8:b27

Also I want to delete the Named ranges IF THEY EXIST

I currently have the code attached to a command button for testin
purposes.

--------------------------------

Private Sub CommandButton1_Click()
Dim res As Variant
Dim rng1 As Range, rng2 As Range
Dim rng As Range, cell As Range
Dim Employee As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet


Set ws1 = ThisWorkbook.Worksheets("DataTable")
Set ws2 = ThisWorkbook.Worksheets("Sheet3")


On Error GoTo ErrHandler
Application.EnableEvents = False

With ws2
.Range("a1:a50").ClearContents
.Range("b1:b50").ClearContents
.Range("c1:c50").ClearContents
End With

res = Application.Match(Range("D3"), ws1.Rows(1), 0)

If Not IsError(res) Then
Set rng1 = ws1.Rows(1).Cells(1, res)
Set rng = ws1.Range(ws1.Cells(2, 1), ws1.Cells(2, 1).End(xlDown))
For Each cell In rng
Debug.Print "->" & ws1.Cells(cell.Row, 1); "<-"
If Not IsEmpty(ws1.Cells(cell.Row, rng1.Column)) Then
If ws1.Cells(cell.Row, 1).Value = "Project" Then
If IsEmpty(ws2.Range("a1")) Then
Set rng2 = ws2.Range("a1")
ElseIf IsEmpty(ws2.Range("a2")) Then
Set rng2 = ws2.Range("a2")
Else
Set rng2 = ws2.Range("a1").End(xlDown)(2)
End If
rng2 = ws1.Cells(cell.Row, 2).Value

ElseIf ws1.Cells(cell.Row, 1).Value = "Task" Then
If IsEmpty(ws2.Range("b1")) Then
Set rng2 = ws2.Range("b1")
ElseIf IsEmpty(ws2.Range("b2")) Then
Set rng2 = ws2.Range("b2")
Else
Set rng2 = ws2.Range("b1").End(xlDown)(2)
End If
rng2 = ws1.Cells(cell.Row, 2).Value

Else
If IsEmpty(ws2.Range("c1")) Then
Set rng2 = ws2.Range("c1")
ElseIf IsEmpty(ws2.Range("c2")) Then
Set rng2 = ws2.Range("c2")
Else
Set rng2 = ws2.Range("c1").End(xlDown)(2)
End If
rng2 = ws1.Cells(cell.Row, 2).Value
End If
End If
Next
End If

'These three lines of code create an error if said named range is no
found. Not sure how to skip if they are not found
ActiveWorkbook.Names("MyProjects").Delete
ActiveWorkbook.Names("MyTasks").Delete
ActiveWorkbook.Names("MyRates").Delete

ws2.Activate

'This line which is where I am naming a range returns a runtime erro
1004 - application-defined or object-defined error
Range(ws2.Range("a1"), ws2.Range("A65536").End(xlUp)).Name
"MyProjects"

ErrHandler:
Application.EnableEvents = True
End Su
 
for each nm in this workbook.Names
if lcase(nm.name) = "myproject" or _
lcase(nm.name) = "mytasks" or _
lcase(nm.name) = "myrates") then
nm.Delete
end if
Next

ws2.Activate
With ws2
.Range(.Range("a1"), ws2.cells(rows.count,1) _
.End(xlUp)).Name ="MyProjects"
End With

ErrHandler:
Application.EnableEvents = True
End Sub


your unqualified
Range(ws2.Range("A1") . . .

refers to the sheet that contains the code ( not sheet3/ws2), so that caused
your error.
 
I guess I also should add that you don't need to delete the names if you are
doing it just so you can add them again. If you add them, they will
overwrite any existing name -- essentially just redefining the existing
name.

--
Regards,
Tom Ogilvy



Tom Ogilvy said:
for each nm in this workbook.Names
if lcase(nm.name) = "myproject" or _
lcase(nm.name) = "mytasks" or _
lcase(nm.name) = "myrates") then
nm.Delete
end if
Next

ws2.Activate
With ws2
.Range(.Range("a1"), ws2.cells(rows.count,1) _
.End(xlUp)).Name ="MyProjects"
End With

ErrHandler:
Application.EnableEvents = True
End Sub


your unqualified
Range(ws2.Range("A1") . . .

refers to the sheet that contains the code ( not sheet3/ws2), so that caused
your error.
Click to expand...
 
Back
Top