süz belli bir aralığa aktar

[CILEKESH]

Sub suz_aktar()
Dim sat As Long, Sh As Worksheet
Sheets("veri").Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Sh = Sheets("CekiListesi")
sat = Cells(Rows.Count, "A").End(xlUp).Row
Sh.Range("a1" & Sh.Rows.Count).ClearContents
Range("A1").AutoFilter
Range("A1").AutoFilter Field:=1, Criteria1:=Sh.Range("d9").Value
If WorksheetFunction.Subtotal(103, Range("c13:g37" & sat)) > 1 Then
    Range("c13").CurrentRegion.Copy Sh.Range("c13")
End If
Range("A1").AutoFilter
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sh.Select
End Sub

Bu kodu şu şekilde düzeltmek istiyorum yardımcı olabilir misiniz.

Süzme işlemi "veri" sayfasında yapılacak
Ceki Listesi D9 hücresinde yazan değeri "Veri" A1 de süzecek listelenen sütunlardan

Veri J sütunundaki değerler, "CekiListesi" C13:C37 aralığına yapışacak
Veri W sütunundaki değerler, "CekiListesi" D1337 aralığına yapışacak
Veri D sütunundaki değerler, "CekiListesi" E13:E37 aralığına yapışacak
Veri E sütunundaki değerler, "CekiListesi" F13:F37 aralığına yapışacak
Veri F sütunundaki değerler, "CekiListesi" G13:G37 aralığına yapışacak

işlemler yapıldıktan sonra süzme işlemi iptal edilecek.

Teşekkür ederim

 

[sametozyavuz]

bu iş görür mü

Sub süz()
Application.ScreenUpdating = False
samet = Sheets("CekiListesi").Range("D9").Value
Sheets("CekiListesi").Select
Range("C13:G37").Select
Selection.ClearContents
Range("C13").Select
Sheets("veri").Select
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$w$37").AutoFilter Field:=1, Criteria1:=samet
Range("j2:j37").Copy Sheets("CekiListesi").Range("c13")
Range("w2:w37").Copy Sheets("CekiListesi").Range("d13")
Range("d2:d37").Copy Sheets("CekiListesi").Range("e13")
Range("e2:e37").Copy Sheets("CekiListesi").Range("f13")
Range("f2:f37").Copy Sheets("CekiListesi").Range("g13")
ActiveSheet.Range("$A$1:$w$37").AutoFilter Field:=1
Selection.AutoFilter
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

Sub Düğme1_Tıklat()
Call süz
End Sub

 

[CILEKESH]

Elbette iş görüyor ancak,

Sub süz()
Application.ScreenUpdating = False
samet = Sheets("CekiListesi").Range("D9").Value
Sheets("CekiListesi").Select
Range("C13:G37").Select
Selection.ClearContents
Range("C13").Select
Sheets("veri").Select
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$w$37").AutoFilter Field:=1, Criteria1:=samet
Range([COLOR="Red"]"j2:j37"[/COLOR]).Copy Sheets("CekiListesi").Range("c13")
Range("[COLOR="red"]w2:w37[/COLOR]").Copy Sheets("CekiListesi").Range("d13")
Range("[COLOR="Red"]d2:d37[/COLOR]").Copy Sheets("CekiListesi").Range("e13")
Range("[COLOR="red"]e2:e37[/COLOR]").Copy Sheets("CekiListesi").Range("f13")
Range("[COLOR="red"]f2:f37"[/COLOR]).Copy Sheets("CekiListesi").Range("g13")
ActiveSheet.Range("$A$1:$w$37").AutoFilter Field:=1
Selection.AutoFilter
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

Sub Düğme1_Tıklat()
Call süz
End Sub

kırmızı ile işaretlediğim bölümlerdeki kodlar verileri 37. satıra kadar aktaracak,
oysa "veri" sayfası yüzlerce satıra ulaşacak.
bu durumda şöyle bir kontrol koyabilirmiyiz. örneğin "J" sütununda süzülen verilerin tamamını seçsin, ancak 30 satırdan fazlaysa aktarım yapmadan uyarı versin. "yazdırılacak alan yeterli değil" gibi

 

[CILEKESH]

Ustatlarim konu icin bir cozumu olan var mi

 

[sametozyavuz]

benim yapabileceğim birşey değil. üzgünüm.