Çözüldü Sayfalardaki verileri birleştirme

[kemal turan]

Merhaba,
Bir çalışma kitabında bulunan bazı sayfalardaki verilerin tek sayfada birleştirilmesi için kendim amatörce uyarladığım aşağıdaki kod çalışıyor.
Her sahifede 50.000 satır veri olabildiği için yavaş çalışıyor. Ustaların yazacakları kod ile daha hızlı yapabilmek mümkün diye düşünüyorum.
Teşekkür ederim.

Sub Dikdörtgen1_Tıkla()
Set s10 = Sheets("TOPLAMVERI")
Set s1 = Sheets("KD")
Set s2 = Sheets("KEMAL")
Set s3 = Sheets("SEL3")
Set s4 = Sheets("SEL4")
Set s5 = Sheets("SEL5")
Set s6 = Sheets("EXP")
Set s7 = Sheets("INFOGROUP")
Set s8 = Sheets("INFOPACK")
Set s9 = Sheets("PLN")

For i = 2 To s3.Range("a500000").End(xlUp).Row
sonsatır1 = s10.Range("a500000").End(xlUp).Row + 1
s10.Cells(sonsatır1, 1) = s3.Name
s10.Cells(sonsatır1, 2) = s3.Cells(i, "c")
s10.Cells(sonsatır1, 3) = s3.Cells(i, "d")
s10.Cells(sonsatır1, 4) = s3.Cells(i, "l")
s10.Cells(sonsatır1, 5) = s3.Cells(i, "m")
s10.Cells(sonsatır1, 6) = s3.Cells(i, "n")
Next i
End Sub

 

[RBozkurt]

Deneyin hocam, yapay zekayı kullanın. Bu işlemler için bire bir. Hata varsa da hatayı yazın düzeltir.

Sub Dikdörtgen1_Tıkla()
    Dim s10 As Worksheet
    Dim s3 As Worksheet
    Dim i As Long
    Dim sonsatır1 As Long
    Dim data As Variant
    Dim rowCount As Long
    
    ' Performans iyileştirmeleri
    Application.ScreenUpdating = False ' Ekran güncellemelerini kapat
    Application.Calculation = xlCalculationManual ' Hesaplamaları manuel moda al
    Application.EnableEvents = False ' Olayları devre dışı bırak

    ' Çalışma sayfalarını ayarla
    Set s10 = Sheets("TOPLAMVERI")
    Set s3 = Sheets("SEL3")

    ' Kopyalanacak aralığı al
    rowCount = s3.Range("A500000").End(xlUp).Row - 1
    data = s3.Range("C2:N" & rowCount + 1).Value

    ' Verileri hedef sayfaya kopyala
    For i = 1 To rowCount
        sonsatır1 = s10.Range("A500000").End(xlUp).Row + 1
        With s10
            .Cells(sonsatır1, 1) = s3.Name ' Sayfa adını ekle
            .Cells(sonsatır1, 2) = data(i, 1) ' C sütununu ekle
            .Cells(sonsatır1, 3) = data(i, 2) ' D sütununu ekle
            .Cells(sonsatır1, 4) = data(i, 10) ' L sütununu ekle
            .Cells(sonsatır1, 5) = data(i, 11) ' M sütununu ekle
            .Cells(sonsatır1, 6) = data(i, 12) ' N sütununu ekle
        End With
    Next i

    ' Ayarları eski haline getir
    Application.ScreenUpdating = True ' Ekran güncellemelerini aç
    Application.Calculation = xlCalculationAutomatic ' Hesaplamaları otomatik moda al
    Application.EnableEvents = True ' Olayları etkinleştir
End Sub

 

[kemal turan]

Çok teşekkür ederim.
Yaş 60.. 45 de başladık.
selametle kalınız

 

[kemal turan]

9 sayfada 70000 satır 1 dk. süper..

 

[RBozkurt]

Ne mutlu problem çözülmesi, iyi çalışmalar.

 

[Necdet]

Merhaba,
Sayfa yapınızın A1 hücresinden başladığını ve ilk satırın başlık olduğunu varsayarak, aşağıdaki kodları dener misiniz?
Hızını merak ediyorum.
Topluca adlı sayfada birleştirir, siz bunu kendinize göre uyarlayınız.

Sub Birlestir()

Dim arr As Variant
Dim r   As Long
Dim sh  As Worksheet
Dim shT As Worksheet

Set shT = Sheets("Topluca")

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

shT.Cells.ClearContents

For Each sh In Sheets
    If Not sh.Name = shT.Name Then
        r = shT.Cells(Rows.Count, "A").End(3).Row + 1
        If r = 2 Then
            r = 1
            arr = sh.Range("A1").CurrentRegion.Value
        Else
            arr = sh.Range("A1").CurrentRegion.Offset(1).Value
        End If
        shT.Range("A" & r).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End If
Next sh

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

End Sub