Referencing output on a drop down field from two columns

[Guest]

Greatly appreciate any help with this.

On one worksheet called 'Budget' I have one cell that is the PROJECT field
(B5)

On Column A Rows 19 to 81 is a data validation list field called 'Donor' on
the same worksheet.

The list of Projects and their donors resides on a second worksheet called
'Data'

The list looks like this
Column A Column B
Project Donor
01001 6374
01001 5540
01001 4303
04001 9901
04002 9915
04002 9901


What I am trying to accomplish is when a user enters a project in B5 on
budget worksheet, the donor fields reference that project on the Data
worksheet and list all available donors for the project.

Example:
User enters 04002 project
Donor field shows 9901 on drop down

Thanks





I have an array but it is not working...thanks for the help.

 

[kounoike]

Assuming Project and Donor reside in A1 and B1 in 'Data' sheet respectively,

Put Worksheet_SelectionChange below into worksheet module named 'Data'
and Put donorlist below into standard module, then set cursor to e.g. A20 in
'Budget' sheet and see how it works.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim slist
If Target.Column <> 1 Then 'Change here if not approprite
Exit Sub
ElseIf Target.Row < 19 Then 'Change here if not approprite
Exit Sub
End If
On Error Resume Next
Application.EnableEvents = False
'Change Worksheets("Budget").Range("b5") to your address
slist = donorlist(Worksheets("Budget").Range("b5").Value)
slist = Join(slist, ",")
If slist = "" Then
slist = " "
End If
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=slist
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Application.EnableEvents = True
End Sub

'Put donorlist below into standard module

Function donorlist(ByVal s As String)
Dim n As Long
Dim rng As Range, rng1 As Range
Dim ar
Const project = "A1" 'Change - Project address
Const donor = "B1" 'Change - Donor address
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("Data") 'Change here
n = .Range(donor).Column - .Range(project).Column
..Range(project).AutoFilter field:=1, Criteria1:=s, Operator:=xlAnd
Set rng = .AutoFilter.Range
Set rng1 = rng.Offset(1, n).Resize(rng.Rows.Count - 1, 1). _
SpecialCells(xlCellTypeVisible)
If IsEmpty(rng1) Then
Set rng = Nothing
Else
Set rng = rng1
End If
ReDim ar(rng.Count - 1)
For Each r In rng
ar(i) = r.Value
i = i + 1
Next
..AutoFilterMode = False
End With
donorlist = ar
End Function

keizi