kod çok yavaş çalışıyor alternatif ne olabilir

[AKTAY27]

selam arkadaşlar;

aşağıdaki kullanmakta olduğum kod satır sayısından dolayı çok yavaş çalışmakta 10.000 kalem hareket var ve bunların arasında arama yaptırdığım zaman kod yavaşlıyor kodu hızlandırmanın yolu var mı ?


-----------------------------------------------
Private Sub fatnoara_Change()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'----------------------------------------------------
Dim s1 As Worksheet
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set s1 = Sheets("YÜKLENEN_VERİ")
ListView1.ListItems.Clear
ListView1.Sorted = False
Set alan = s1.Range("D2" & s1.[A65536].End(3).Row)
Set Bul = alan.Find("*" & fatnoara.Value & "*")
If Not Bul Is Nothing Then
adres = Bul.Address
Do
i = Bul.Row
With ListView1
.ListItems.Add , , s1.Cells(i, "A")
X = X + 1
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "P")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "Q")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "B")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "C")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "D")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "E")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "F")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "G")
.ListItems(X).ListSubItems.Add , , FormatNumber(s1.Cells(i, "H"))
.ListItems(X).ListSubItems.Add , , FormatNumber(s1.Cells(i, "I"))
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "J")
.ListItems(X).ListSubItems.Add , , FormatNumber(s1.Cells(i, "K"))
.ListItems(X).ListSubItems.Add , , FormatNumber(s1.Cells(i, "L"))
.ListItems(X).ListSubItems.Add , , FormatNumber(s1.Cells(i, "M"))
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "N")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "O")
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "R")
.ListItems(X).ListSubItems.Add , , FormatNumber(s1.Cells(i, "S"))
.ListItems(X).ListSubItems.Add , , FormatNumber(s1.Cells(i, "T"))
.ListItems(X).ListSubItems.Add , , s1.Cells(i, "A") 'LİSTVİEW 0 İNDEKSİ ATAMADIĞI İÇİN ENSONA ATTIM
End With
Set Bul = alan.FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> adres
'ListView1.Sorted = True 'Sıralama işlemini açtık.
'ListView1.SortOrder = lvwAscending '(A dan Z ye küçükten büyüğe sıralı yap)
ListView1.SortOrder = 0
ListView1.SortKey = 3
End If
Set s1 = Nothing
Set alan = Nothing
Set Bul = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Label100 = "Listelenen Kayıt Sayısı = " & ListView1.ListItems.Count
'--------------------------------------------
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[ReBiwAr]

örnek dosya ekler misiniz bu işlemi kendi bilgisayarımda çalıştırmak istiyorum. Belki tek komutta işi çözebiliriz.

İyi Çalışmalar.