Excel to return looked up values from drop down list?

[riteoh]

Hi - I posted this problem several months ago - thought it was working, and marked the thread closed, only to find a problem - which has not been answered - so starting again!

I have a series of Australian Postcodes, that can have multiple locations listed. EG.

2000 Sydney
2000 Bankstown
2000 Lismore

The locations also have other values listed against them, in 5 columns.

I need to write a lookup that will prompt the user to select the location from a postcode, and when the location value is selected from (drop down list?) the values against those locations returned.

So for example in the attached spreadsheet, the Value in Cell C16 (user input) is 2000, Cell D16 will return a drop down list of Sydney, Bankstown, Lismore, and when this location is selected, the values recorded in Cells C, D, E, F and G against Lismore the drop down list selection) are returned.

Have no idea where to start. Ideas please? CARE : Whilst 2000 may have Sydney recorded against it, there are multiple location NAMES that have different postcodes, so the list could look like

2000 Sydney
2000 Bankstown
2000 Lismore
3152 Sydney
3155 Wantirna
4265 Wantirna

My excel file is attached, however 75% of the data has had to be cut out due to size limitations. The front page however should give an idea of what I need to do. All help appreciated!

[Kenneth Hobs]

I guess you mean this thread. http://www.vbaexpress.com/forum/showthread.php?52981-Excel-to-return-looked-up-values-from-drop-down-list&p=328264

[JKwan]

give this a try

[riteoh]

Thanks - on opening the file, I'm getting an error - Method 'Rows' of Object'_Global ' failed. Seems to be pointing to the function

Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function

[JKwan]

hmm, I don't know.....
I just downloaded the file and I opened it without any problem.....
Maybe try to download the file again?

[riteoh]

Strange - working now. I guess this works - but not ideally.
In a perfect world, Cell C16 is freeform, Cell D16 is a dropdown box based on the value in C16, Columns E - K then return the values based on D16 (combined with - I don't need to see EVERY possible value for C16 - only the one that I select....

[JKwan]

i will try to make it a perfect world for you.
i thought by selecting the post code is better (who can remember all those numbers.....)

[JKwan]

ok, put the kids to sleep, got sometime, here is I hope your perfect world solution. NOTE - I put 2 controls onto the sheet a combo box and a listbox. I think the listbox works better, I will let you decide

[Kenneth Hobs]

In a Module, paste this and add the Reference as commented, the Microsoft Scripting Runtime.

Sub DDPostcodes(aRange As Range)
With Worksheets("PostCodes - master")
MakeUniqeSortedDataValidationList aRange, .Range("B3", .Range("B" & Rows.Count).End(xlUp))
End With
End Sub


Sub DDLocations(aRange As Range)
Dim c As Range, r As Range, s As String
s = aRange.Offset(, -1).Value 'The Postcode
With Worksheets("PostCodes - master")
Set c = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
Set r = FoundRanges(c, s)
If r Is Nothing Then Exit Sub
Set r = r.Offset(, -1) 'Ranges with Postcode matched
MakeUniqeSortedDataValidationList aRange, r
End With
End Sub


Sub MakeUniqeSortedDataValidationList(vRange As Range, usRange As Range)
Dim a() As Variant, s As String, u() As Variant
u = rList(usRange)
u() = UniqueArrayByDict(u)
a() = ArrayListSort(u)
s = Join(a, ",")
With vRange.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=s
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
End Sub


'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
'Dim dic As Object 'Late Binding method - Requires no Reference
'Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
Dim dic As Dictionary 'Early Binding method
Set dic = New Dictionary 'Early Binding Method
Dim e As Variant
dic.CompareMode = compareMethod
'BinaryCompare=0
'TextCompare=1
'DatabaseCompare=2
For Each e In Array1d
If Not dic.Exists(e) Then dic.Add e, Nothing
Next e
UniqueArrayByDict = dic.Keys
End Function

'http://www.vbaexpress.com/forum/showthread.php?48491
Function ArrayListSort(sn As Variant, Optional bAscending As Boolean = True)
With CreateObject("System.Collections.ArrayList")
Dim cl As Variant
For Each cl In sn
.Add cl
Next

.Sort 'Sort ascendending
If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
ArrayListSort = .ToArray()
End With
End Function

Function FoundRanges(fRange As Range, fStr As String) As Range
Dim objFind As Range
Dim rFound As Range, FirstAddress As String

With fRange
Set objFind = .Find(What:=fStr, After:=fRange.Cells(fRange.Rows.Count, fRange.Columns.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
If Not objFind Is Nothing Then
Set rFound = objFind
FirstAddress = objFind.Address
Do
Set objFind = .FindNext(objFind)
If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
End If
End With
Set FoundRanges = rFound
End Function

Function rList(aRange As Range) As Variant
Dim a() As Variant, rr As Range, c As Range, v As Variant
ReDim a(1 To aRange.Cells.Count)
Dim i As Integer

For Each rr In aRange.Areas
For Each c In rr
i = i + 1
a(i) = c.Value
Next c
Next rr

rList = a()
End Function






Right click your "Look Up" sheet, View Code, and Paste:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, f As Range

On Error GoTo EndNow
Application.EnableEvents = False

Set r = Intersect(Range("C16:C" & Rows.Count), Target)
If Not r Is Nothing Then
Application.Range("D" & r.Row & ":K" & r.Row).ClearContents
Application.EnableEvents = True
Range("D" & r.Row).Select
GoTo EndNow
End If

Set r = Intersect(Range("D16:D" & Rows.Count), Target)
If Not r Is Nothing Then
Application.Range("E" & r.Row & ":K" & r.Row).ClearContents
With Worksheets("PostCodes - master")
Set f = .Range("A3", .Range("A" & Rows.Count).End(xlUp))
Range("E" & r.Row).Value2 = .Range("BL" & f.Row)
Range("G" & r.Row).Value2 = .Range("BG" & f.Row)
Range("H" & r.Row).Value2 = .Range("BH" & f.Row)
Range("I" & r.Row).Value2 = .Range("BI" & f.Row)
Range("J" & r.Row).Value2 = .Range("BJ" & f.Row)
End With
End If

EndNow:
Application.EnableEvents = True
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range

Set r = Intersect(Range("C16:C" & Rows.Count), Target)
If Not r Is Nothing Then DDPostcodes r

Set r = Intersect(Range("D16:D" & Rows.Count), Target)
If Not r Is Nothing Then DDLocations r
End Sub

[Kenneth Hobs]

Crossposted at: http://www.ozgrid.com/forum/showthread.php?t=196241