automatische suche bei eingabe

Private Sub TextBox1_Change()
On Error Resume Next
Dim arr() As Variant, Tmp As Variant, wks As Worksheet, zelle,
preis1 As Currency, preis2 As Currency, preisg As Currency
Dim index As Integer
Dim X, anz, icount
anz = 0
zelle = Cells(12, 4)
Set wks = Sheets("Stamm")
X = wks.Range("C65536").End(xlUp).Row
'ListBox1.RowSource = ""
Tmp = wks.Range("C4:CH" & 4 + X)
X = X - 4
If TextBox1 = "" Then
On Error GoTo weiter
ReDim arr(0 To 5, 0 To X - 1)
For index = 1 To UBound(Tmp, 1)
On Error Resume Next
arr(0, icount) = Tmp(index, 23)
arr(1, icount) = Tmp(index, 35)
arr(2, icount) = Tmp(index, 20)
preis1 = Tmp(index, 37)
preis2 = Tmp(index, 38)
preisg = preis1 + preis2
arr(3, icount) = Format(preisg, "0.00")
arr(4, icount) = Tmp(index, 2)
arr(5, icount) = Tmp(index, 1)
Next
weiter:
ListBox1.Clear
Else
For index = 1 To UBound(Tmp, 1)
If LCase(Left(Tmp(index, 23), Len(TextBox1))) = LCase(TextBox1) Then
ReDim Preserve arr(0 To 5, 0 To icount)
arr(0, icount) = Tmp(index, 23)
arr(1, icount) = Tmp(index, 35)
arr(2, icount) = Tmp(index, 20)
preis1 = Tmp(index, 37)
preis2 = Tmp(index, 38)
preisg = preis1 + preis2
arr(3, icount) = Format(preisg, "0.00")
arr(4, icount) = Tmp(index, 2)
arr(5, icount) = Tmp(index, 1)
icount = icount + 1
anz = anz + 1
End If
Next
End If
werticount = icount
If icount  0 Then
ListBox1.Column = arr
End If
End Sub