Textbox Listeleme ve Boşaltma

[o2l3m]

Textbox ile Listbox da arama yaparken ve kutuyu boşaltırken çok fazla bekliyorum.
Sorun veya sıkıntı nerde olabilir?


Private Sub TextBox5_Change()

Dim k As Range, adrs As String, j As Byte, a As Long, myarr()
ReDim myarr(1 To 3, 1 To 1)
With Worksheets("MALZEME")
Me.ListBox3.RowSource = vbNullString
If .FilterMode Then .ShowAllData
Set k = .Range("A2:A65536").Find(TextBox5.Text & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
adrs = k.Address
Do
a = a + 1
ReDim Preserve myarr(1 To 3, 1 To a)
For j = 1 To 3
myarr(j, a) = .Cells(k.Row, j).Value
Next j
Set k = .Range("A2:A65536").FindNext(k)
Loop While Not k Is Nothing And k.Address <> adrs
ListBox3.Column = myarr
End If
End With

End Sub

 

[askm]

Örnek dosyanız üzerinden bakmak çözümü daha çabuklaştıracaktır.

 

[o2l3m]

Listboxa aldığım satır sayısı 20.000 civarı.
Pc i7 işlemci olmasına rağmen kod halen yavaş çalışıyor.

Alternatif bir çözüm öneriniz varmıdır?


Private Sub TextBox5_Change()



Dim k As Range, adrs As String, j As Byte, a As Long, myarr()
ReDim myarr(1 To 3, 1 To 1)
With Worksheets("MALZEME")
Me.ListBox3.RowSource = vbNullString
'Show all records of Database on Sheet1
If .FilterMode Then .ShowAllData
Set k = .Range("A2:A65536").Find(TextBox5.Text & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
adrs = k.Address
Do
a = a + 1
ReDim Preserve myarr(1 To 3, 1 To a)
For j = 1 To 3
myarr(j, a) = .Cells(k.Row, j).Value
Next j
Set k = .Range("A2:A65536").FindNext(k)
Loop While Not k Is Nothing And k.Address <> adrs
ListBox3.Column = myarr
End If
End With

End Sub

 

[o2l3m]

Yokmu bir çözüm? :-(