Kriter sayısı arttıkça pc kasılıyor.

[mnz]

Merhaba,

Aşağıdaki S3 sayfasındaki binlerce satırlık veriden S1 deki kriterler doğrultusunda uyanları S2 sayfasına atıyorum. Ancak kriter sayısı arttıkça bilgisayarın zorlandığını görüyorum. Bilgisayarı zorlamadan nasıl yapılabilir?
Veri süz ün kullanımını bilmediğim için uzun yolu tercih ettim.

Set sy = Sheets("S3")
Set ss = Sheets("S1")
Set sz = Sheets("S2")
UserForm3.Label3.Caption = "LÜTFEN BEKLEYİNİZ..."
DoEvents
u = ss.[A65536].End(3).Row
t = sy.[A65536].End(3).Row
sz.Range("a2:k2000") = ""
If ss.Range("B2") <> "" Then k1 = ss.Range("B2").Value / 1
If ss.Range("B3") <> "" Then k2 = ss.Range("B3").Value / 1
If ss.Range("B4") <> "" Then k3 = ss.Range("B4").Value / 1
If ss.Range("B5") <> "" Then k4 = ss.Range("B5").Value / 1
If ss.Range("B6") <> "" Then k5 = ss.Range("B6").Value / 1

For y = 2 To u
For i = 2 To t
If sy.Cells(i, "C").Value = ss.Cells(y, "A").Value And sy.Cells(i, "F").Value = k1 Or sy.Cells(i, "C").Value = ss.Cells(y, "A").Value And sy.Cells(i, "F").Value = k2 Or sy.Cells(i, "C").Value = ss.Cells(y, "A").Value And sy.Cells(i, "F").Value = k3 Or sy.Cells(i, "C").Value = ss.Cells(y, "A").Value And sy.Cells(i, "F").Value = k4 Or sy.Cells(i, "C").Value = ss.Cells(y, "A").Value And sy.Cells(i, "F").Value = k5 Then
v = sz.[A65536].End(3).Row
sz.Cells(v + 1, "A") = sy.Cells(i, "A").Value
sz.Cells(v + 1, "B") = sy.Cells(i, "B").Value
sz.Cells(v + 1, "C") = sy.Cells(i, "C").Value
sz.Cells(v + 1, "D") = sy.Cells(i, "D").Value
sz.Cells(v + 1, "E") = sy.Cells(i, "E").Value
sz.Cells(v + 1, "F") = sy.Cells(i, "F").Value
sz.Cells(v + 1, "G") = sy.Cells(i, "G").Value
End If
Next
Next
UserForm3.Label37.Caption = ""

 

[Zeki Gürsoy]

"CurrentRegion" kriteriyle arattırırsanız, filtrelenen verilerin aktarımıyla ilgili (kısa kod) örnekler bulabilirsiniz.

 

[veyselemre]

Bir örnek eklerseniz, daha iyi anlaşılır, çözüm daha kolay olur.