Dizi formülü Makroyu aşırı derecede yavaşlatıyor

[huseyinvurkan]

Aşağıdaki makro ile Liste sayfasındaki karışık isim soyisim ve numaralar, Sınıf sayfasındaki bilgilere göre okul sayfasına düzenli bir şekilde oluşturuluyor. Makro sorunsuz çalışıyor. Ancak Başarı isimli bir sayfada dizi formülüyle Okul Sayfasından sınıf listeleri çağrılacak. Bu sayfaya dizi formülleri oluşturulunca makronun çalışma süresi yaklaşık 5 - 10 dakikaya çıkıyor. oysa makronunnormal süresi 3 - 4 saniye. Bu sorun aşılabilir mi? Öğrenci sayısı yaklaşık 1500 kişi. (Ek deki örnek dosyada 100 öğrenci ile makro süresi yaklaşık 1 dakika 1500 olunca beklemekten bıkıyor insan) Veya bu sınıf çağırma işlemi Dizi formülsüz yapılabilir mi? Teşekkürler.


Sub okul_sayfasına_tasnifle()
Application.ScreenUpdating = False
On Error Resume Next
Sheets("OKUL").Range("a2:d65536").ClearContents
Set s1 = ThisWorkbook.Worksheets("LİSTE")
Set s2 = ThisWorkbook.Worksheets("OKUL")
For i = 2 To s1.Range("b65536").End(xlUp).Row
If s1.Cells(i, "b") <> "" Then
sonsatir = s2.Range("c65536").End(xlUp).Row + 1
s2.Cells(sonsatir, "a") = sonsatir - 1
s2.Cells(sonsatir, "c") = s1.Cells(i, "b")
s2.Cells(sonsatir, "d") = s1.Cells(i, "e") & " " & s1.Cells(i, "j")
End If
Next i
Call sınıf_bul
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Sub sınıf_bul()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("SINIF")
Set s2 = ThisWorkbook.Worksheets("OKUL")
For i = 2 To s2.Range("a65536").End(xlUp).Row
For k = 3 To s1.Range("c65536").End(xlUp).Row
If s2.Cells(i, "a") >= s1.Cells(k, "c") And s2.Cells(i, "a") <= s1.Cells(k, "d") Then s2.Cells(i, "b") = s1.Cells(k, "a")
Next k
Next i
Application.ScreenUpdating = True
End Sub


http://s2.dosya.tc/server/n5ipgz/REHBERLIK4.xls.html

 

[Muzaffer Ali]

Aşağıdaki kodları deneyin.

Sub okul_sayfasına_tasnifle()
Application.Calculation = XlCalculation.xlCalculationManual
Application.ScreenUpdating = False
On Error Resume Next
Sheets("OKUL").Range("a2:d65536").ClearContents
Set s1 = ThisWorkbook.Worksheets("LİSTE")
Set s2 = ThisWorkbook.Worksheets("OKUL")
For i = 2 To s1.Range("b65536").End(xlUp).Row
If s1.Cells(i, "b") <> "" Then
sonsatir = s2.Range("c65536").End(xlUp).Row + 1
s2.Cells(sonsatir, "a") = sonsatir - 1
s2.Cells(sonsatir, "c") = s1.Cells(i, "b")
s2.Cells(sonsatir, "d") = s1.Cells(i, "e") & " " & s1.Cells(i, "j")
End If
Next i
Call sınıf_bul
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Sub sınıf_bul()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("SINIF")
Set s2 = ThisWorkbook.Worksheets("OKUL")
For i = 2 To s2.Range("a65536").End(xlUp).Row
For k = 3 To s1.Range("c65536").End(xlUp).Row
If s2.Cells(i, "a") >= s1.Cells(k, "c") And s2.Cells(i, "a") <= s1.Cells(k, "d") Then s2.Cells(i, "b") = s1.Cells(k, "a")
Next k
Next i
Application.ScreenUpdating = True
Application.Calculation = XlCalculation.xlCalculationAutomatic
End Sub

 

[huseyinvurkan]

Sayın Dalgalilur. Eline Sağlık. Makro sorunsuz çalıştı. Gerçekten teşekkürler. Gerçek dosyaya uyarlayınca sorun çıkarsa tekrar rahatsız ederim.