Aktarda yardım

[mcetinkaya65]

Hayırlı Cumalar.
Yardımlarınızla hazırladığım programa birkaç ilave ettirmemiz gerekiyor, tabi ki mümkünse.
Ana sayfanın A sütununa yazılan isme göre Örnek sayfasından bir sayfa ekliyor ve köprü oluşturuyor. Oluşturulan sayfadaki Topluya aktar butonuna tıklayınca B3 den I171 kadar olan bölümü toplu sayfasına aktarıyor.

Benim istediğim.

1.Yukarki mantıkla örnek sayfasına öyle bir makrolu buton ekleyelim ki (Tut lis) aktar dediğimizde B3 den-O171 aralığının d sütununda dolu olanlarını, Tut lis sayfasının B3 den-O264 aralığını temizleyip B3 den başlayıp aktarması

2.Birde tut listesine bir buton ekleyelim; Tıkladığımızda B1-F280aralığının d stununa göre filtreleyip dolu olanlarını Tutanak arşivi sayfasının en son dolu hücresinden sonraya bir boş satır bırakıp aktarması

Saygılarımla..

 

[Ömer BARAN]

Merhabalar.

İstediğiniz işlemler için aşağıdaki kod'ları kullanabilirsiniz.
-- 1 numaralı isteğinizi gerçekleştirecek olan kod Sub FİLTRELE_AKTAR() başlıklı olan,
-- 2 numaralı isteğinizi gerçekleştirecek olan ise Sub ARŞİVE_AKTAR() başlıklı olan.

.

[B][COLOR="Blue"][FONT="Arial Narrow"]Sub FİLTRELE_AKTAR()[/COLOR][/B]
Set ö = Sheets("Örnek"): Set tl = Sheets("Tut Lis"): ösonsat = ö.[C65536].End(3).Row
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
ö.Activate
If tl.[C65536].End(3).Row > 2 Then tl.Range("B3:O" & tl.[C65536].End(3).Row).ClearContents
ö.Range("$A$2:$I$" & ösonsat).AutoFilter Field:=4, Criteria1:="<>"
If ö.[D65536].End(3).Row > 2 Then: ö.Range("B3:O" & ösonsat).Copy
tl.Activate: tl.Range("B3").Select: ActiveSheet.Paste
Selection.Interior.Color = xlNone: Application.CutCopyMode = False: tl.[A2].Activate: ö.Activate
ö.Range("$A$2:$I$" & ösonsat).AutoFilter Field:=4
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Veriler Tut Lis sayfasına aktarıldı....": End If
[COLOR="blue"][B]End Sub[/B][/COLOR]

[B][COLOR="Red"]Sub ARŞİVE_AKTAR()[/COLOR][/B]
Set ta = Sheets("Tutanak Arşiv"): Set tl = Sheets("Tut Lis")
tasonsat = ta.[D65536].End(3).Row + 2
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
tl.Activate
If tl.[C65536].End(3).Row > 2 Then
tl.Range("B1:F" & tl.[B65536].End(3).Row).Copy
ta.Activate: ta.Range("B" & tasonsat).Select: ActiveSheet.Paste
Selection.Interior.Color = xlNone: Application.CutCopyMode = False
ta.Cells(ta.[D65536].End(3).Row + 1, 1).Activate: tl.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Tut Lis sayfasındaki veriler Tutanak Arşiv sayfasına aktarıldı....": End If
[B][COLOR="red"]End Sub[/FONT][/COLOR][/B]

 

[mcetinkaya65]

Üstad 1. çalışmıyor
2. ise
A1-F280 arası yazdırılacak alan
D3-D264 aralığını baz alıp dolu olan hücrelerine göre filtreyip aktarması