Kopyala-Yapıştır Makro Kodlarının Kısaltılması

[truvaliman]

Merhaba arkadaşlar. Örnek dosyamı boyutu yüksek olduğu ve çok sayfa olduğu için yükleyemiyorum bu yüzden kusura bakmayın. Aşağıdaki kodlar ile bir sayfadan diğer sayfaya verileri kopyalıyorum ama kopyala-yapıştır ile yapıldığı için işlem çok uzun sürüyor. Bu kodları ve işlemin süresini nasıl kısaltabilirim acaba? Yardımlarınız için şimdiden teşekkür ederim...

Sub Akbank()
Dim say
say = WorksheetFunction.CountA(Sheets("Akbank").Range("E3:E65536").Value) + 2
Sheets("Akbank").Range("$A$2:$T$65536").AutoFilter Field:=5, Criteria1:=Array( _
        "Munferit.Kapora", _
        "Munferit.İade(-)", "Acenta.Munferit.EB", "Acenta.Munferit.Odeme", "Acenta.Grup.Kaparo", "Acenta.Grup.Odeme", "Acenta.Grup.İade (-)", "Acenta.Munferit.İade (-)"), Operator:= _
        xlFilterValues

'Akbank Kaparo
Sheets("Akbank").Select
If Sheets("Akbank").Range("G1").Value > 0 Then
Range("A3:A" & say).Select
Selection.Copy
Sheets("Kaparolar").Select
[D65536].End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=False

Sheets("Akbank").Select
Range("C3:C" & say).Select
Selection.Copy
Sheets("Kaparolar").Select
[C65536].End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=False

Sheets("Akbank").Select
Range("D3:D" & say).Select
Selection.Copy
Sheets("Kaparolar").Select
[B65536].End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=False

Sheets("Akbank").Select
Range("F3:F" & say).Select
Selection.Copy
Sheets("Kaparolar").Select
[A65536].End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=False
Application.CutCopyMode = False

Sheets("Akbank").Select
Range("W3:W" & say).Select
Selection.Copy
Sheets("Kaparolar").Select
[E65536].End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=False

Else
[A65536].End(xlUp).Offset(0, 0).Select
End If
End Sub

 

[halit3]

bu kodu bir dene

Sub Akbank()
Dim say
say = WorksheetFunction.CountA(Sheets("Akbank").Range("E3:E65536").Value) + 2
Sheets("Akbank").Range("$A$2:$T$65536").AutoFilter Field:=5, Criteria1:=Array("Munferit.Kapora", "Munferit.İade(-)", _
"Acenta.Munferit.EB", "Acenta.Munferit.Odeme", "Acenta.Grup.Kaparo", "Acenta.Grup.Odeme", "Acenta.Grup.İade (-)", _
"Acenta.Munferit.İade (-)"), Operator:=xlFilterValues

If Sheets("Akbank").Range("G1").Value > 0 Then
Sheets("Akbank").Range("A3:A" & say).Copy
Sheets("Kaparolar").[D65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=False
Sheets("Akbank").Range("C3:C" & say).Copy
Sheets("Kaparolar").[C65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=False
Sheets("Akbank").Range("D3:D" & say).Copy
Sheets("Kaparolar").[B65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=False
Sheets("Akbank").Range("F3:F" & say).Copy
Sheets("Kaparolar").[A65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=False
Sheets("Akbank").Range("W3:W" & say).Copy
Sheets("Kaparolar").[E65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=False
Application.CutCopyMode = False
Else
[A65536].End(xlUp).Offset(0, 0).Select
End If
End Sub

 

[truvaliman]

Teşekkürler Halit hocam. ilk fırsatta deneyeceğim sağolun...

 

[halit3]

Birde bunu dene

Sub Akbank()
Dim say
say = WorksheetFunction.CountA(Sheets("Akbank").Range("E3:E65536").Value) + 2
Sheets("Akbank").Range("$A$2:$T$65536").AutoFilter Field:=5, Criteria1:=Array("Munferit.Kapora", "Munferit.İade(-)", _
"Acenta.Munferit.EB", "Acenta.Munferit.Odeme", "Acenta.Grup.Kaparo", "Acenta.Grup.Odeme", "Acenta.Grup.İade (-)", _
"Acenta.Munferit.İade (-)"), Operator:=xlFilterValues

If Sheets("Akbank").Range("G1").Value > 0 Then
Sheets("Akbank").Range("A3:A" & say).Copy
Sheets("Kaparolar").Range("D2").PasteSpecial Paste:=3
Sheets("Akbank").Range("C3:C" & say).Copy
Sheets("Kaparolar").Range("C2").PasteSpecial Paste:=3
Sheets("Akbank").Range("D3:D" & say).Copy
Sheets("Kaparolar").Range("B2").PasteSpecial Paste:=3
Sheets("Akbank").Range("F3:F" & say).Copy
Sheets("Kaparolar").Range("A2").PasteSpecial Paste:=3
Sheets("Akbank").Range("W3:W" & say).Copy
Sheets("Kaparolar").Range("E2").PasteSpecial Paste:=3
Application.CutCopyMode = False
End If
End Sub