Soru Makro Yavaş Çalışıyor

[okan32]

AŞAĞIDAKİ KOD İLE ÖDEME LİSTESİ SAYFASINDAKİ VERİLERİ ÖDEME RAPOR SAYFASINA AKTARIYORUM. FAKAT KOD ÇOK YAVAŞ VERİ AKTARIYOR. SANIRIM FOR NEXT DÖNGÜSÜNDE SIKINTI AMA BİR TÜRLÜ HIZLANDIRAMADIM. ALTERNATİF BİR MAKRODA OLABİLİR YARDIMLARINIZ İÇİN ŞİMDİDEN TEŞEKKÜRLER...

Sub ekle()

Dim s1, s2 As Worksheet
Dim sonhucre, son As Long
    Set s1 = Sheets("Ödeme Listesi")
    Set s2 = Sheets("Ödeme Rapor")
   
     
sonhucre = s1.Range("B65536").End(xlUp).Row

Select Case MsgBox("Verileri Arşive Aktarmadan Önce Çıktısını Alınız Çünkü Veriler SİLİNECEK BİLGİLERİNİZE!!!!!!???", vbYesNo Or vbQuestion Or vbDefaultButton1, "> > > D İ K K A T < < <")

Case vbYes


For i = 4 To sonhucre
son = s2.Cells(Rows.Count, "B").End(3).Row + 1
    s2.Cells(son, 1) = s1.Cells(i, 1)
    s2.Cells(son, 2) = s1.Cells(i, 2)
    s2.Cells(son, 3) = s1.Cells(i, 3)
    s2.Cells(son, 4) = s1.Cells(i, 4)
    s2.Cells(son, 5) = s1.Cells(i, 5)
    s2.Cells(son, 6) = s1.Cells(i, 6)
   
Next i
MsgBox "Verileri Arşive Aktarma işlemi tamamlandı...", vbInformation, "ALİ KOÇ"

'Worksheets("Ödeme Listesi").Range("B4:C100,E4:F100").ClearContents

Case vbNo

MsgBox "Verileri Arşive Aktarma işlemini iptal ettiniz...", vbInformation, "ALİ KOÇ"

Exit Sub
End Select


End Sub

 

[Ömer BARAN]

Merhaba.
Bence yavaş dediğiniz makro da içerisinde olacak şekilde bir örnek belge eklerseniz alternatif cevaplar alma olasılığınız artar.
.

 

[Ömer BARAN]

Verdiğiniz kod'dan anladığım kadarıyla bir sayfadaki 4'üncü satırdan sonrasında dolu olan A:H sütun aralığının tümünü
diğer sayfaya DEĞER olarak aktarıyorsunuz.
Bu işlem için For...Next şeklinde oluşturulacak satır numarası döngüsü yerine doğrudan dolu alanı kopyalayıp yapıştırmak pratik olur.
İşlem buysa aşağıdaki gibi deneyin. (Yeşil olan satırın başına TEK TIRNAK işaretini, siz de verdiğiniz kod'da eklediğiniz için ekledim)

Sub ekle()
Dim s1, s2 As Worksheet
Dim sonhucre, son As Long
    Set s1 = Sheets("Ödeme Listesi")
    Set s2 = Sheets("Ödeme Rapor")
    sondolu = s1.Cells(Rows.Count, "B").End(3).Row
    If sondolu < 4 Then
        MsgBox "Aktarılacak veri yok!", vbInformation
        Exit Sub
    Else
        Select Case MsgBox("Verileri Arşive Aktarmadan Önce Çıktısını Alınız Çünkü Veriler SİLİNECEK BİLGİLERİNİZE!!!!!!???", _
            vbYesNo Or vbQuestion Or vbDefaultButton1, "> > > D İ K K A T < < <")
        Case vbYes
            son = s2.Cells(Rows.Count, "B").End(3).Row + 1
            s1.Range("A4:H" & sondolu).Copy: s2.Cells(son, "A").PasteSpecial Paste:=xlPasteValues
'            s1.Range("B4:C" & sondolu & ", E4:F" & sondolu).ClearContents
            MsgBox "Verileri Arşive Aktarma işlemi tamamlandı...", vbInformation, "ALİ KOÇ"
        Case vbNo
            MsgBox "Verileri Arşive Aktarma işlemini iptal ettiniz...", vbInformation, "ALİ KOÇ"
        End Select
    End If
End Sub

 

[okan32]

ÇOK TEŞEKKÜR EDERİM ÖMER BEY KOD İŞİMİ GÖRDÜ