Sayfadan sayfaya veri aktarma makrosu

[akmes]

Merhaba, Herkese iyi günler dilerim.

Aşağıda verdiğim makro ile bir sayfadan diğer sayfaya veri aktarıyoruz. Ama aktarırken çok ağır aktarıyor. Makroyu hızlandırmanın bir yolu var mıdır.
Yardımlarınızı rica ediyorum.

Sub ekle()
Dim s1, s2, s3 As Worksheet
Dim sonhucre, son As Long
Set s1 = Sheets("600_18KDV Hepsi")
Set s2 = Sheets("600 Ayırma")

Sheets("600 Ayırma").Select
Range("a2:g" & Rows.Count).ClearContents
s2.Cells(1, 1).Value = "Tarih"
s2.Cells(1, 2) = "Fiş No"
s2.Cells(1, 3) = "Sr"
s2.Cells(1, 4) = "Açıklama"
s2.Cells(1, 7) = "Alacak Tut."
s2.Rows(1).Font.Bold = True

sonhucre = s1.Range("A65536").End(xlUp).Row


For i = 2 To sonhucre
son = s2.Cells(Rows.Count, "A").End(3).Row + 1
s2.Cells(son, 1) = s1.Cells(i, 1) 'Tarih
s2.Cells(son, 2) = s1.Cells(i, 2) 'Fiş No
s2.Cells(son, 3) = s1.Cells(i, 3) 'Sr
s2.Cells(son, 4) = s1.Cells(i, 4) 'Açıklama
s2.Cells(son, 7) = s1.Cells(i, 6) 'Alacak Tut.


Next i


End Sub

 

[necati]

Merhaba,
Hep aynı kolonları kopyalıyorsanız şunu deneyebilirsiniz:

Sub ekle()

Dim s1, s2, s3 As Worksheet
Dim sonhucre, son As Long
Set s1 = Sheets("600_18KDV Hepsi")
Set s2 = Sheets("600 Ayırma")

sonhucre = s1.Range("A65536").End(xlUp).Row
son = s2.Cells(Rows.Count, "A").End(3).Row + 1

s2.Select
Range("a2:g" & son).ClearContents
x = Array("600_18KDV Hepsi", "600 Ayırma")
Sheets(x).FillAcrossSheets Worksheets("600_18KDV Hepsi").Range("A2:G" & sonhucre), Type:=xlFillWithAll
End Sub

 

[akmes]

Merhaba,
Hep aynı kolonları kopyalıyorsanız şunu deneyebilirsiniz:

Sub ekle()

Dim s1, s2, s3 As Worksheet
Dim sonhucre, son As Long
Set s1 = Sheets("600_18KDV Hepsi")
Set s2 = Sheets("600 Ayırma")

sonhucre = s1.Range("A65536").End(xlUp).Row
son = s2.Cells(Rows.Count, "A").End(3).Row + 1

s2.Select
Range("a2:g" & son).ClearContents
x = Array("600_18KDV Hepsi", "600 Ayırma")
Sheets(x).FillAcrossSheets Worksheets("600_18KDV Hepsi").Range("A2:G" & sonhucre), Type:=xlFillWithAll
End Sub

Necati Bey, evet çok hızlanmış teşekkür ederim. Emiğinize sağlık, yalnız "600 Ayırma" sayfasın da sütunlara atarken A,B,C,D,E aynı sadece F sütununu G sütununa atması lazım "600 Ayırma" sayfasın da F sütunu boş kalmalı bu şekilde düzeltebilir miyiz?

 

[necati]

Bu yöntem birebir aynı olan aralıkların taşınması için kullanılıyor. O halde A-E arası için yine bunu kullanalım. Farklı olan F'den G'ye olan kısmı için ekleme yapalım.

Sub ekle()

Dim s1, s2, s3 As Worksheet
Dim sonhucre, son As Long
Set s1 = Sheets("600_18KDV Hepsi")
Set s2 = Sheets("600 Ayırma")

sonhucre = s1.Range("A65536").End(xlUp).Row
son = s2.Cells(Rows.Count, "A").End(3).Row + 1

s2.Select
Range("a2:g" & son).ClearContents
x = Array("600_18KDV Hepsi", "600 Ayırma")
Sheets(x).FillAcrossSheets Worksheets("600_18KDV Hepsi").Range("A2:E" & sonhucre), Type:=xlFillWithAll
s1.Range("F2:F" & sonhucre).Copy
s2.Range("G2").PasteSpecial
End Sub

 

[akmes]

Bu yöntem birebir aynı olan aralıkların taşınması için kullanılıyor. O halde A-E arası için yine bunu kullanalım. Farklı olan F'den G'ye olan kısmı için ekleme yapalım.

Sub ekle()

Dim s1, s2, s3 As Worksheet
Dim sonhucre, son As Long
Set s1 = Sheets("600_18KDV Hepsi")
Set s2 = Sheets("600 Ayırma")

sonhucre = s1.Range("A65536").End(xlUp).Row
son = s2.Cells(Rows.Count, "A").End(3).Row + 1

s2.Select
Range("a2:g" & son).ClearContents
x = Array("600_18KDV Hepsi", "600 Ayırma")
Sheets(x).FillAcrossSheets Worksheets("600_18KDV Hepsi").Range("A2:E" & sonhucre), Type:=xlFillWithAll
s1.Range("F2:F" & sonhucre).Copy
s2.Range("G2").PasteSpecial
End Sub

Necati Bey, Süper oldu çok teşekkür ederim. Tekrar elinize, emeğinize sağlık.

 

[necati]

Rica ederim, iyi çalışmalar.