VBA code to filter listbox as you type in a textbox

[BungleNZ]

Hi,

I have a list of customers in listbox1 (the text values of which come from a spreadsheet), that I want to refine as I type in textbox1. I'm not sure if it's possilbe, but I would like it to work similar to the itunes search (if you're familiar with it) where it searchs for any occurance of the text within the list as opposed to just searching for the letters at the beginning of the word.

Thanks in advance to anyone who can help.

 

[Blade Hunter]

Need more info, what do you parse into and receive back from that function?

If you post your code, it would probably be easier to incorporate it into the existing code above.

 

[jindon]

try

Private Sub UserFilter_Change()
Dim a, e
UserFilter.Clear
With Sheets("names")
    a = .Range("a2", .Range("a" & Rows.Count).end(xlUp)).Value
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each e In a
        If InStr(1, e, UserFilter.Value, 1) > 0 Then .item(e) = e
    Next
    If .Count > 0 Then UserFilter.List = .keys
End With
End Sub

 

[BungleNZ]

Sorry it took so long. I had to write the code out again.

[face=Courier New]Private Sub UserForm_activate()
Dim MyUniqueList As Variant, i As Long
With Me.ListBox1
.Clear ' clear the listbox content
MyUniqueList = UniqueItemList(Range("Customers"), True)
For i = 1 To UBound(MyUniqueList)
.AddItem MyUniqueList(i)
Next i
.ListIndex = 0 ' select the first item
End With
End Sub

Private Function UniqueItemList(InputRange As Range, _
Horizontallist As Boolean) As Variant
Dim cl As Range, cunique As New Collection, i As Long, ulist() As Variant
Application.Volatile
On Error Resume Next
For Each cl In InputRange
If cl.Formula <> "" Then
cunique.Add cl.Value, CStr(cl.Value)
End If
Next cl
UniqueItemList = ""
If cunique.Count > 0 Then
ReDim ulist(1 To cunique.Count)
For i = 1 To cunique.Count
ulist(i) = cunique(i)
Next i
UniqueItemList = ulist
If Not Horizontallist Then
UniqueItemList = _
Application.WorksheetFunction.Transpose(UniqueItemList)
End If
End If
On Error GoTo 0
End Function[/face]

Need more info, what do you parse into and receive back from that function?

If you post your code, it would probably be easier to incorporate it into the existing code above.

 

[BungleNZ]

That code does not look like it pasted correctly, hopefully this looks better.

Private Sub UserForm_activate()
Dim MyUniqueList As Variant, i As Long
With Me.ListBox1
.Clear ' clear the listbox content
MyUniqueList = UniqueItemList(Range("Customers"), True)
'Customers is a dynamic named range in the sheet
For i = 1 To UBound(MyUniqueList)
.AddItem MyUniqueList(i)
Next i
.ListIndex = 0 ' select the first item
End With
End Sub

Private Function UniqueItemList(InputRange As Range, _
Horizontallist As Boolean) As Variant
Dim cl As Range, cunique As New Collection, i As Long, ulist() As Variant
Application.Volatile
On Error Resume Next
For Each cl In InputRange
If cl.Formula <> "" Then
cunique.Add cl.Value, CStr(cl.Value)
End If
Next cl
UniqueItemList = ""
If cunique.Count > 0 Then
ReDim ulist(1 To cunique.Count)
For i = 1 To cunique.Count
ulist(i) = cunique(i)
Next i
UniqueItemList = ulist
If Not Horizontallist Then
UniqueItemList = _
Application.WorksheetFunction.Transpose(UniqueItemList)
End If
End If
On Error GoTo 0
End Function

Need more info, what do you parse into and receive back from that function?

If you post your code, it would probably be easier to incorporate it into the existing code above.

 

[Blade Hunter]

Sorry about the delay.

So I looked through the replies and once again, Jindon amazes me with his use of the dictionary .

I modified his code a bit to suit your purpose and to make it easier for you to taylor (Renamed some variable and the references to the form)


I think this will do exactly as you want. Thanks for the code Jindon

Private Sub UserFilter_Change()
Dim NameList, Entry
FilterNames.FilteredList.Clear
With Sheets("Names")
    NameList = .Range("a2", .Range("a" & Rows.Count).End(xlUp)).Value
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each Entry In NameList
        If InStr(1, Entry, UserFilter.Value, 1) > 0 Then .Item(Entry) = Entry
    Next
    If .Count > 0 Then FilterNames.FilteredList.List = .keys
End With
End Sub


Private Sub UserForm_Activate()
Dim Entry
FilterNames.FilteredList.Clear
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each Entry In Sheets("Names").Range("a2", Sheets("Names").Range("a" & Rows.Count).End(xlUp)).Value
        .Item(Entry) = Entry
    Next
    If .Count > 0 Then FilterNames.FilteredList.List = .keys
End With
End Sub

All you need to do is sub in Range("Customers") on the range and you are good to go .


Cheers

Dan

 

[BungleNZ]

That's great. Thank you both for helping me out on this one!

Sorry about the delay.

So I looked through the replies and once again, Jindon amazes me with his use of the dictionary .

I modified his code a bit to suit your purpose and to make it easier for you to taylor (Renamed some variable and the references to the form)


I think this will do exactly as you want. Thanks for the code Jindon

Private Sub UserFilter_Change()
Dim NameList, Entry
FilterNames.FilteredList.Clear
With Sheets("Names")
    NameList = .Range("a2", .Range("a" & Rows.Count).End(xlUp)).Value
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each Entry In NameList
        If InStr(1, Entry, UserFilter.Value, 1) > 0 Then .Item(Entry) = Entry
    Next
    If .Count > 0 Then FilterNames.FilteredList.List = .keys
End With
End Sub
 
 
Private Sub UserForm_Activate()
Dim Entry
FilterNames.FilteredList.Clear
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each Entry In Sheets("Names").Range("a2", Sheets("Names").Range("a" & Rows.Count).End(xlUp)).Value
        .Item(Entry) = Entry
    Next
    If .Count > 0 Then FilterNames.FilteredList.List = .keys
End With
End Sub

All you need to do is sub in Range("Customers") on the range and you are good to go .


Cheers

Dan

 

[phevos]

and what happen if i need 5 columns in my listbox and 5 textboxes to filter the data... is possible to modify this code to work with this filters???????

 

[jindon]

and what happen if i need 5 columns in my listbox and 5 textboxes to filter the data... is possible to modify this code to work with this filters???????

Possible but how ?

 

[phevos]

for example if i write in one textbox... the listbox will reduce to a number of possibles anwers and if i write the second textbox i will reduce again the listbox

One friend send this code and told that with some variations i can get 5 columns in one listbox with 5 textbox to filter the data, but i cant understand this code if someone have any idea please


Private Sub tbxFind_Change()

Dim i As Long
Dim sCrit As String

'Add asterisks around text for all matches
'UCase is used to make filter case-insensitive
sCrit = "*" & UCase(Me.tbxFind.Text) & "*"

With Me.lbxCustomers
'Start with a fresh list
.List = vaCustNames
'Loop through the list backward - always a good
'idea when you're deleting stuff
For i = .ListCount - 1 To 0 Step -1
'Remove the line if it doesn't match
'UCase used again here
If Not UCase(.List(i)) Like sCrit Then
.RemoveItem i
End If
Next i
End With

End Sub

 

[phevos]

move to:

http://www.mrexcel.com/forum/showthread.php?p=1840507&posted=1#post1840507

thanks