Makroyu nasıl kısaltırım.

[AS3434]

Aşağıda linkte göndermiş olduğum dosyada makroda kısaltmayı nasıl yaparız.

c = [B65536].End(3).Row + 1
olarak c yi tanımlıyorum, fakat her kopyalamada tekrar tanımlamak zorunda kalıyorum.

Makro bilgim Olmadığından bir türlü altından kalkamadım.
Kısa bir örnek vermek gerekirse makro şöyle;

Application.ScreenUpdating = False
   Sheets("AKTARIM").Range("B2:E65536").ClearContents
   Sheets("DATA").Range("A6:D" & Sheets("DATA").[D65536].End(xlUp).Row).Copy
   c = [B65536].End(3).Row + 1
   Sheets("AKTARIM").Cells(c, 2).Select
   ActiveSheet.Paste
   Sheets("DATA").Range("E6:H" & Sheets("DATA").[E65536].End(xlUp).Row).Copy
   c = [B65536].End(3).Row + 1
   Sheets("AKTARIM").Cells(c, 2).Select
   ActiveSheet.Paste
   Sheets("DATA").Range("I6:L" & Sheets("DATA").[I65536].End(xlUp).Row).Copy
   c = [B65536].End(3).Row + 1
   Sheets("AKTARIM").Cells(c, 2).Select
   ActiveSheet.Paste

http://excel.web.tr/showthread.php?p=153907#post153907

 

[hamitcan]

Aşağıdaki şekilde dener misiniz?

Sub aktar()
Sheets("AKTARIM").Range("B2:e65536").ClearContents
For t = 1 To 12 Step 4
c = Sheets("AKTARIM").[B65536].End(3).Row + 1
d = Sheets("DATA").Cells(65536, t).End(3).Row + 1
Range(Cells(6, t), Cells(d, t + 3)).Copy Sheets("AKTARIM").Cells(c, 2)
Next
End Sub

 

[AS3434]

Sn. Hamitcan

O şekilde olmaz.
Çünkü DATA sayfasında ki tanımladığım hücre aralıklarını (a:d , E:h, I:L...vs..)
AKTARIM sayfasında altalta gelecek şekilde kopyalama yapıyorum.

Sizin gönderdiğiniz şekilde Data sayfası bir seferde yanyana gelir.

Her kopyalamadan sonra son dolu satırı bulması gerekiyor. (Göndermiş olduğum dosyaya bakarsanız sevinirim.)

İlginiz için teşekkür ederim.

 

[hamitcan]

Yukarıdaki kodu güncelledim.

 

[AS3434]

Sn. Hamitcan

Olmamış diyordum ki, Butonu DATA sayfasına koyduğunuzu fark ettim.
Şu şekilde değiştirdim.

Sub aktar()
Application.ScreenUpdating = False
Sheets("AKTARIM").Range("B2:e65536").ClearContents
For t = 1 To 32 Step 4
c = Sheets("AKTARIM").[B65536].End(3).Row + 1
Sheets("data").Select
Range(Cells(6, t), Cells(50, t + 3)).Copy Sheets("AKTARIM").Cells(c, 2)
Next
Sheets("AKTARIM").Select
[A1].Select
Application.ScreenUpdating = True
End Sub

İlginiz için teşekkür ederim.