Thanks a lot for your interest in my problem.
I pasted your code accordingly but I get a "Complie error : undefined
Sub or Function" message when the code reaches the line Persons =
Filter(TextArray, "@" & TextBox1.Text, True, vbTextCompare)
FILTER is the problem here !
What do you suggest ???
Forget my other post... I'll assume you have an earlier version of Excel/VBA
(which does not support the Filter function) and just give you code that
should work on your system. I removed the call to VBA6's Filter function,
substituted one I found online (see the comments for attributions) and
changed my code to make use of it. Delete all the code I gave you earlier
and copy/paste all the code following my signature instead.
Rick
Dim TextArray() As String
Private Sub UserForm_Initialize()
Dim X As Long
Dim LastRow As Long
Const StartRow As Long = 2
Const NamesColumn As String = "B"
TextBox1.Text = ""
TextBox1.EnterKeyBehavior = True
With Worksheets("Sheet1")
LastRow = .Cells(Rows.Count, NamesColumn).End(xlUp).Row
ReDim TextArray(0 To LastRow - StartRow + 1)
For X = StartRow To LastRow
TextArray(X - StartRow) = "@" & .Cells(X, NamesColumn)
ListBox1.AddItem .Cells(X, NamesColumn)
Next
End With
End Sub
Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With TextBox1
If KeyCode = vbKeyLeft Then
ListBox1.ListIndex = -1
.SelStart = Len(.Text)
.SetFocus
ElseIf KeyCode = vbKeyReturn Then
.Text = ListBox1.List(ListBox1.ListIndex)
.SelStart = Len(.Text)
.SetFocus
End If
End With
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1.Text = ListBox1.List(ListBox1.ListIndex)
End Sub
Private Sub TextBox1_Change()
Dim X As Long
Dim ListHeight As Long
Dim UboundPersons As Long
Dim Individual As String
Dim Persons() As String
UboundPersons = FilterB01(TextArray, "@" & TextBox1.Text, _
Persons, True, vbTextCompare)
If Len(TextBox1.Text) Then
If UboundPersons > -1 Then
With ListBox1
.Clear
For X = 0 To UboundPersons
.AddItem Mid$(Persons(X), 2)
Next
End With
Else
ListBox1.Clear
For X = 0 To UBound(TextArray)
ListBox1.AddItem Mid$(TextArray(X), 2)
Next
End If
Else
ListBox1.Clear
For X = 0 To UBound(TextArray)
ListBox1.AddItem Mid$(TextArray(X), 2)
Next
End If
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With ListBox1
If KeyCode = vbKeyReturn Then
KeyCode = 0
If .ListCount = 1 Then
TextBox1.Text = .List(0)
TextBox1.SelStart = Len(TextBox1.Text)
Else
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
ElseIf KeyCode = vbKeyDown Or (KeyCode = vbKeyRight And _
.ListCount > 0 And TextBox1.SelStart = Len(TextBox1.Text)) Then
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
End With
End Sub
Private Function FilterB01(SourceArray() As String, _
Match As String, _
TargetArray() As String, _
Optional Include As Boolean = True, _
Optional Compare As VbCompareMethod = vbBinaryCompare) As Long
' by Donald, (e-mail address removed), 20000918
' returns Ubound(TargetArray), or -1 if
' TargetArray is not bound (empty array)
' Code obtained at:
http://www.xbeat.net/vbspeed/c_Filter.htm
Dim i As Long
' make maximal space
ReDim TargetArray(UBound(SourceArray) - LBound(SourceArray))
FilterB01 = -1
For i = LBound(SourceArray) To UBound(SourceArray)
If Len(SourceArray(i)) Then
If Include = CBool(InStr(1, SourceArray(i), Match, Compare)) Then
FilterB01 = FilterB01 + 1
TargetArray(FilterB01) = SourceArray(i)
End If
Else
' we want a match if Source and Match are both ""
' but InStr does not work on zero-length strings, so:
If Include = Not CBool(Len(Match)) Then
FilterB01 = FilterB01 + 1
' is "" anyway, so we spare this line:
''TargetArray(FilterB01) = SourceArray(i)
End If
End If
Next
' erase or shrink
If FilterB01 = -1 Then
Erase TargetArray
Else
ReDim Preserve TargetArray(FilterB01)
End If
End Function
