teknikyapı
Altın Üye
- Katılım
- 30 Nisan 2007
- Mesajlar
- 396
- Excel Vers. ve Dili
- Office 365
- Altın Üyelik Bitiş Tarihi
- 13-01-2026
Merhaba.
Aşağıda uzman arkadaşlarımdan faydalandığım arama yapan kodlarda nasıl bir düzenleme yaparsak aramayı hızlandırabiliriz acaba? Şu an ilgili sayfada 300 satır var ama ileride 5000 adet satıra çıkabilir.Application.ScreenUpdating diye bir olay olduğunu öğrendim fakat uygulayamadım.YArdımcı olacak arkadaşlara teşekkür ederim.İyi çalışmalar.
Private Sub TextBox7_Change()
Set SR = Sheets("RAYİC")
If OptionButton1 = False And OptionButton2 = False And OptionButton3 = False Then
MsgBox "Lütfen arama kriterini seçiniz !", vbCritical, "Dikkat !"
Exit Sub: End If
ListView1.ListItems.Clear
If OptionButton1 = True Then Set ALAN = Range("A3:A" & [A65536].End(3).Row)
If OptionButton2 = True Then Set ALAN = Range("B3:B" & [B65536].End(3).Row)
If OptionButton3 = True Then Set ALAN = Range("F3:F" & [B65536].End(3).Row)
If OptionButton1 = True Then Set BUL = ALAN.Find(TextBox7.Text & "*", LookAt:=xlWhole)
If OptionButton2 = True Then Set BUL = ALAN.Find("*" & TextBox7.Text & "*")
If OptionButton3 = True Then Set BUL = ALAN.Find("*" & TextBox7.Text & "*")
If Not BUL Is Nothing Then
Adres = BUL.Address
Do
satır = BUL.Row
With ListView1
.ListItems.Add , , SR.Cells(satır, 1)
X = X + 1
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 2)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 3)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 4)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 5)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 6)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 7)
SAY = SAY + 1
'eğer hücre başında (*) işareti var ise satırı kırmızı renklendir
If Left(SR.Cells(satır, 2), 1) = "*" Then
.ListItems(X).ListSubItems(1).ForeColor = vbBlue
.ListItems(X).ForeColor = vbBlue
End If
'eğer hücre başında (-) işareti var ise satırı kırmızı renklendir
If Left(SR.Cells(satır, 2), 1) = "-" Then
.ListItems(X).ListSubItems(1).ForeColor = vbRed
.ListItems(X).ForeColor = vbRed
End If
End With
Set BUL = ALAN.FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> Adres
End If
Label1 = SAY & " ADET"
Set SR = Nothing
Set ALAN = Nothing
Set BUL = Nothing
End Sub
Aşağıda uzman arkadaşlarımdan faydalandığım arama yapan kodlarda nasıl bir düzenleme yaparsak aramayı hızlandırabiliriz acaba? Şu an ilgili sayfada 300 satır var ama ileride 5000 adet satıra çıkabilir.Application.ScreenUpdating diye bir olay olduğunu öğrendim fakat uygulayamadım.YArdımcı olacak arkadaşlara teşekkür ederim.İyi çalışmalar.
Private Sub TextBox7_Change()
Set SR = Sheets("RAYİC")
If OptionButton1 = False And OptionButton2 = False And OptionButton3 = False Then
MsgBox "Lütfen arama kriterini seçiniz !", vbCritical, "Dikkat !"
Exit Sub: End If
ListView1.ListItems.Clear
If OptionButton1 = True Then Set ALAN = Range("A3:A" & [A65536].End(3).Row)
If OptionButton2 = True Then Set ALAN = Range("B3:B" & [B65536].End(3).Row)
If OptionButton3 = True Then Set ALAN = Range("F3:F" & [B65536].End(3).Row)
If OptionButton1 = True Then Set BUL = ALAN.Find(TextBox7.Text & "*", LookAt:=xlWhole)
If OptionButton2 = True Then Set BUL = ALAN.Find("*" & TextBox7.Text & "*")
If OptionButton3 = True Then Set BUL = ALAN.Find("*" & TextBox7.Text & "*")
If Not BUL Is Nothing Then
Adres = BUL.Address
Do
satır = BUL.Row
With ListView1
.ListItems.Add , , SR.Cells(satır, 1)
X = X + 1
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 2)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 3)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 4)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 5)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 6)
.ListItems(X).ListSubItems.Add , , SR.Cells(satır, 7)
SAY = SAY + 1
'eğer hücre başında (*) işareti var ise satırı kırmızı renklendir
If Left(SR.Cells(satır, 2), 1) = "*" Then
.ListItems(X).ListSubItems(1).ForeColor = vbBlue
.ListItems(X).ForeColor = vbBlue
End If
'eğer hücre başında (-) işareti var ise satırı kırmızı renklendir
If Left(SR.Cells(satır, 2), 1) = "-" Then
.ListItems(X).ListSubItems(1).ForeColor = vbRed
.ListItems(X).ForeColor = vbRed
End If
End With
Set BUL = ALAN.FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> Adres
End If
Label1 = SAY & " ADET"
Set SR = Nothing
Set ALAN = Nothing
Set BUL = Nothing
End Sub