Kod aşırı derecede yavaşladı

[vurkan]

Merhaba Sayın Ayhan Karışıklığı önlemek için Yazıcı sayfasının S2:S45 aralığına okuldaki sınıfları belirlemek için (Başka bir çalışmada sizden aldığım kod)

=EĞERHATA(İNDİS(VERİ!$B$3:VERİ!$B$2000;KÜÇÜK(EĞER(SIKLIK(EĞER(VERİ!$B$3:VERİ!$B$2000<>"";KAÇINCI("~"&VERİ!$B$3:VERİ!$B$2000;VERİ!$B$3:VERİ!$B$2000&"";0));SATIR(VERİ!$B$3:VERİ!$B$2000)-SATIR(VERİ!$B$3)+1);SATIR(VERİ!$B$3:VERİ!$B$2000)-SATIR(VERİ!$B$3)+1);SATIRSAY($S$2:S2)));"")

dizi formülüyle sınıfları VERİ sayfasından aldım. okulun sınıf sayısı 41 ben 3 tane fazla bıraktım. Kodu aşağıdaki gibi yaptım.

Sub DİŞ_2()
Dim ws1 As Worksheet: Set ws1 = Sheets("YAZICI")
Dim ws2 As Worksheet: Set ws2 = Sheets("DİŞ")
Dim say As Long: say = Application.WorksheetFunction.CountIf(Sheets("YAZICI").Range("S2:S45"), "2*")
Dim i As Long
For i = 2 To say + 1
ws2.[A1] = ws1.Cells(i, "S")
ws2.PrintOut
Application.Wait (Now + TimeValue("0:00:01"))
Next i
End Sub

Burada sadece 2 ile başlayan sınıfları yazdırmak istiyorum ama 2. sınıf sayısınca S2, S3, S4 gibi sıradan sınıfları yazdırıyor. Oysa 2. sınıflar S12 den başlamış oluyor. Yani Kod aralıkta seçim yapmadan sınıfları sırayla yazdırıyor. Ne yapmalıyım?

 

[vurkan]

Arkadaşlar Merhaba. Sayın Korhan Ayhan ve Sayın Askm üstadlarımın son katkılarıyla geliştirmeye çalıştığım ÖĞRENCİ PROGRAMI adlı çalışmama san şeklini verirken daha önce Sayın Ayhan üstadın kodlarına eklediğimiz Sayın Askm Üstadın doğum yeri ve tarihini ayırma ek kodları önce çalıştı ama şimdi çalışmıyor. O sayfalara veya kadlara bir ilave de yapmadım. Sebebini bulamadım. Yardımcı olursanız sevinirim.

https://dosya.co/2y511e2lnp98/OGRENCI_PROGRAMI_v10.xls.html


Çalışmayan Kod: OKUL LİSTE sayfasında

Sub Verileri_Aktar()
Dim s1 As Worksheet, s2 As Worksheet
Dim Liste As Variant, Son As Long, Zaman As Double

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Zaman = Timer


Set s1 = ThisWorkbook.Worksheets("OKUL LİSTE")
Set s2 = ThisWorkbook.Worksheets("VERİ")


s2.Range("A3:T" & s2.Rows.Count).ClearContents
s2.Range("A3:T" & s2.Rows.Count).NumberFormat = "General"

Son = s1.Cells(s1.Rows.Count, 1).End(3).Row
Liste = s1.Range("A2:Q" & Son).Value
Satir = 3

For x = 1 To UBound(Liste, 1) Step 21
s2.Cells(Satir, 1) = Satir - 2
s2.Cells(Satir, 2) = Liste(x, 16)
s2.Cells(Satir, 3) = Liste(x, 4)
s2.Cells(Satir, 4) = Liste(x + 1, 4) & " " & Liste(x + 2, 4)
s2.Cells(Satir, 5) = Liste(x + 1, 4)
s2.Cells(Satir, 6) = Liste(x + 2, 4)

s2.Cells(Satir, 7) = Liste(x + 3, 4)
s2.Cells(Satir, 8) = Liste(x + 4, 4)
Kelime = Split(Liste(x + 5, 4)) '(Bu satırdaki Kelime =Mavi zemin renginde oluyor ve kod çalışmıyor. Bu bölümü çıkarınca çalışıyor)
DogumYeri = Kelime(0)
DogumTarihi = Format(Kelime(UBound(Kelime)), "dd.mm.yyyy")
s2.Cells(Satir, 9) = DogumYeri
s2.Cells(Satir, 10) = DogumTarihi

s2.Cells(Satir, 11) = Liste(x + 7, 4)
s2.Cells(Satir, 12) = Liste(x + 8, 4)
s2.Cells(Satir, 13) = Liste(x + 9, 4)
s2.Cells(Satir, 14) = Liste(x + 10, 4)
s2.Cells(Satir, 15) = Liste(x + 7, 11)
s2.Cells(Satir, 16) = Liste(x + 8, 11)
s2.Cells(Satir, 17) = Liste(x + 9, 11)
s2.Cells(Satir, 18) = Liste(x + 16, 4)
Satir = Satir + 1
Next

s2.Range("A3:T" & Satir - 1).Borders.LineStyle = xlContinuous

Set s1 = Nothing
Set s2 = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Sub Verileri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Satir As Long
    Dim Liste As Variant, Son As Long, Zaman As Double
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Zaman = Timer
    
    Set S1 = ThisWorkbook.Worksheets("OKUL LİSTE")
    Set S2 = ThisWorkbook.Worksheets("VERİ")
    
    S2.Range("A3:T" & S2.Rows.Count).ClearContents
    S2.Range("A3:T" & S2.Rows.Count).NumberFormat = "General"

    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Liste = S1.Range("A2:Q" & Son).Value
    Satir = 3
    
    For X = 1 To UBound(Liste, 1) Step 21
        S2.Cells(Satir, 1) = Satir - 2
        S2.Cells(Satir, 2) = Liste(X, 16)
        S2.Cells(Satir, 3) = Liste(X, 4)
        S2.Cells(Satir, 4) = Liste(X + 1, 4) & " " & Liste(X + 2, 4)
        S2.Cells(Satir, 5) = Liste(X + 1, 4)
        S2.Cells(Satir, 6) = Liste(X + 2, 4)
        S2.Cells(Satir, 7) = Liste(X + 3, 4)
        S2.Cells(Satir, 8) = Liste(X + 4, 4)
        S2.Cells(Satir, 9) = Split(Trim(Replace(Liste(X + 5, 4), "   ", " ")), " ")(0)
        S2.Cells(Satir, 10) = CDate(Split(Trim(Replace(Liste(X + 5, 4), "   ", " ")), " ")(2))
        S2.Cells(Satir, 11) = Liste(X + 7, 4)
        S2.Cells(Satir, 12) = Liste(X + 8, 4)
        S2.Cells(Satir, 13) = Liste(X + 9, 4)
        S2.Cells(Satir, 14) = Liste(X + 10, 4)
        S2.Cells(Satir, 15) = Liste(X + 7, 11)
        S2.Cells(Satir, 16) = Liste(X + 8, 11)
        S2.Cells(Satir, 17) = Liste(X + 9, 11)
        S2.Cells(Satir, 18) = Liste(X + 16, 4)
        Satir = Satir + 1
    Next
    
    S2.Range("A3:T" & Satir - 1).Borders.LineStyle = xlContinuous
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[vurkan]

Sayın Korhan Üstadım Kod çalıştı ancak Type mismatch uyarısı verdi.

 

[Korhan Ayhan]

Demek ki tablonuzda uyumsuz bir veri var. Hata veren dosyanızı paylaşırsanız kontrol edebiliriz.

 

[vurkan]

Korhan Üstadım 1İ sınıfında hata verdi. İ sınıfına kadar hata vermedi. E okuldan veri aktarırken hata olmuş olabilir. Yarın tekrar aktarıp deneyeceğim inşallah. İyi geceler

 

[vurkan]

Üstadım Merhaba 1İ sınıfını defalarca indirdim. Denedim hep aynı oldu. sizin Doğum Yeri ayırma satırınız güzel çalışıyor. Ama tarih ayırma satırı 16. öğrenci alıp hata veriyor. 16. satırdaki öğrencinin doğum yeri diğerlerinden farklı olarak

EDREMİT BALIKESİR 17/08/2013 şeklinde 2 kelime bir tarihten oluşuyor. Sebep bu olabilir mi. Diğer sınıflarda da bazı öğrencilerin

GAZİMAĞUSA/K.K.T.C.
ABİNSKKRASNODARRUSYA

şeklinde olanlar da var. Sebep bu olabilir mi? Saygılar.

 

[Korhan Ayhan]

Sorun devam ediyor mu?

Ediyorsa ilgili sınıfla ilgili veriyi benimle paylaşmanızı rica edeceğim. Dilerseniz mail adresime dosyanızı gönderebilirsiniz.

 

[vurkan]

Sayın Korhan Ayhan üstadım;
İlgili konuyu Sayın Ömer Baran üstadın yardımıyla çözdüm. Dosyayı tamamladım. Teorik olarak her şey hayalimdeki gibi oldu. Rabbim hepinizden razı olsun. Sayelerinizde sorular sorun olmaktan çıkıyor. Gerçek verilerle yazıcı çıktıları almadım. Eğer bir sorunla karşılaşırsam tekrar rahatsız ederim. Saygılar sunuyorum.