Sayfalara Veri Dağıtma Kod Revize Yardımı

[Believing]

Sayın Uzman arkadaşlar,

Ekteki çalışmaDA “Veri Güncelle” isimli buton ile kapalı kitaptan veri transferi yapıyorum.
“Sayfalara Dağıt” isimli buton ile daha önceden oluşturduğum sayfalara, “VERİTABANI” sayfasındaki verileri sayfa isimlerine göre dağıtıyorum.
Asıl çalışmadaki veriler ay sonunda 9.000 satıra ulaştığından ve bu verilerin 32 adet sayfaya dağıtılması gerektiği için kodlar çok yavaş çalışmaktadır.
Mevcutta yavaş çalışan kodların revize edilmesi konusunda çok değerli yardımlarınızı rica ediyorum.

Saygılarımla,
Ömer Ali ÜZÜMCÜ

Örnek Çalışma Linki:
http://s2.dosya.tc/server9/91wtne/ORNEK_BELIEVING_30052019.rar.html

 

[ÖmerBey]

Merhaba,
Kullandığınız kodların başına

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

satırlarını; sonuna da

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

satırlarını ekleyip deneyiniz.
İyi çalışmalar...

 

[Believing]

Sayın Ömer bey,

Konuya gösterdiğiniz ilgi ve çözümünüz için size çok teşekkür ederim.
ALLAH sizden ve sevdiklerinizden razı olsun.
İyi geceler.

Saygılarımla,
Ömer Ali ÜZÜMCÜ

 

[ÖmerBey]

Rica ederim Ömer Ali Bey,
Allah hepimizden razı olsun.
İyi geceler, iyi çalışmalar...

 

[Ziynettin]

yanlış cevap nedeniyle silindi.

 

[Korhan Ayhan]

Alternatif,

Sizin kullandığınız döngüye göre biraz daha performans sağlar.

Option Explicit

Sub Sayfalara_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Son As Long, Zaman As Double
    Dim Veri As Variant, Satir As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("VERİTABANI")
    
    S1.Range("D2:D1048576").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("AZ2"), Unique:=True

    For X = 3 To S1.Cells(S1.Rows.Count, "AZ").End(3).Row
        If S1.Cells(X, "AZ").Value <> "" Then
            S1.Range("A2:AJ" & Rows.Count).AutoFilter 4, S1.Cells(X, "AZ").Value
            Son = S1.Cells(S1.Rows.Count, 6).End(3).Row
            If Son > 2 Then
                Set S2 = Sheets(S1.Cells(X, "AZ").Value)
                Satir = S2.Cells(S2.Rows.Count, 1).End(3).Row + 1
                S1.Range("D4:E" & Son).Copy
                S2.Cells(Satir, 1).PasteSpecial xlPasteValues
                S2.Cells(Satir, 1).PasteSpecial xlPasteFormats

                S1.Range("I4:X" & Son).Copy
                S2.Cells(Satir, 3).PasteSpecial xlPasteValues
                S2.Cells(Satir, 3).PasteSpecial xlPasteFormats
            End If
        End If
    Next

    On Error Resume Next
    S1.Range("AZ:AZ").Delete
    S1.ShowAllData
    On Error GoTo 0

    Set S1 = Nothing
    Set S2 = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Believing]

Sayın Korhan Ayhan,

Konuya gösterdiğiniz ilgi ve yardımınız için size çok teşekkür ederim.
ALLAH sizden ve sevdiklerinizden razı olsun.
Cuma gününün ve Kadir gecesinin hayırlara vesile olmasını dilerim.

Saygılarımla,
Ömer Ali ÜZÜMCÜ