Sayfalar arasında veri taşıma kodundaki aşırı yavaşlık

[Feylosof]

İyi geceler;

Sub aktar()
Dim s1, s2, s3 As Worksheet
Dim sonhucre, son As Long
    Set s1 = Sheets("LİSTE")
    Set s2 = Sheets("Sayfa2")
    

For i = 2 To s1.Cells(Rows.Count, "B").End(xlUp).Row
For son = 2 To s2.Cells(Rows.Count, "B").End(xlUp).Row + 1
i = son
    s2.Cells(son, 2) = s1.Cells(i, 2)
    s2.Cells(son, 3) = s1.Cells(i, 3)
    s2.Cells(son, 4) = s1.Cells(i, 5)
    s2.Cells(son, 5) = s1.Cells(i, 6)
    s2.Cells(son, 6) = s1.Cells(i, 7)
    s2.Cells(son, 7) = s1.Cells(i, 8)
    s2.Cells(son, 8) = s1.Cells(i, 9)

Next
Next
End Sub

Kendimce siteden derleyerek karalamaya çalıştığım kod ektedir. Kodun amacı liste sayfasından "d" kolununu atlayarak sayfa2 ye taşımak. Kod çalışıyor ve amaç hasıl oluyor ama takriben 1200 satırlık bir dosyada 20 dakikaya varan zaman içinde tamamlanıyor. Bu kodu nasıl düzenlesek zaman almaz.
Şimdiden teşekkürler.

 

[çıtır]

Deneyiniz;

Sub Aktar()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim i As Integer
Set s1 = Sheets("LİSTE"): Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
son = s1.Cells(65355, "A").End(3).Row
s2.Range("A2:H" & s2.Range("H" & Rows.Count).End(3).Row + 1).Clear
a = s1.Range("A2:I" & son).Value
     ReDim b(1 To UBound(a), 1 To 8)
For i = 1 To UBound(a)
say = say + 1
b(say, 1) = a(i, 1): b(say, 2) = a(i, 2)
b(say, 3) = a(i, 3): b(say, 4) = a(i, 5)
b(say, 5) = a(i, 6): b(say, 6) = a(i, 7)
b(say, 7) = a(i, 8): b(say, 8) = a(i, 9)
Next i
        If say = 0 Then
        Application.ScreenUpdating = True
MsgBox "LİSTELENEÇEK BİLGİ BULUNAMADI.", vbInformation
Exit Sub
    Else
End If
           s2.Range("A2").Resize(say, 8) = b
           Application.ScreenUpdating = True
           MsgBox "İŞLEM TAMAM"
End Sub

 

[Feylosof]

Sayın @çıtır çok teşekkür ederim. Bana ne kadar zaman kazandıracak tahmin edersiniz. Elinize, zihninize ve emeğinize sağlık.

 

[çıtır]

Deneyerek hızını görebilirsiniz.Rica ederim.Dönüş yaptığınız için teşekkür ederim.

 

[çıtır]

Şimdi denedim benim bilgisayarımda 1200 satırı 0,03 sn aktarıyor.

Sub Aktar()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim i As Integer
Set s1 = Sheets("LİSTE"): Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
Zaman = Timer
son = s1.Cells(65355, "A").End(3).Row
 If son = 1 Then
MsgBox "LİSTELENEÇEK BİLGİ BULUNAMADI.", vbInformation
Exit Sub
End If
s2.Range("A2:H" & s2.Range("H" & Rows.Count).End(3).Row + 1).Clear
a = s1.Range("A2:I" & son).Value
     ReDim b(1 To UBound(a), 1 To 8)
For i = 1 To UBound(a)
say = say + 1
b(say, 1) = a(i, 1): b(say, 2) = a(i, 2)
b(say, 3) = a(i, 3): b(say, 4) = a(i, 5)
b(say, 5) = a(i, 6): b(say, 6) = a(i, 7)
b(say, 7) = a(i, 8): b(say, 8) = a(i, 9)
Next i
      s2.Range("A2").Resize(say, 8) = b
           Application.ScreenUpdating = True
           MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub