Bir Tablodan Sadece Dolu Satırları Alarak Diğer Sayfadaki Boş Tabloya Yapıştırmak

[respecteams]

Soru Başlıkta Gayet Açıkladım. Sayfa3 teki tabloda olan verileri(boş tablolar kalıyor) alıp sayfa2 de ki tabloya aktarmasını istiyorum alt alta olacak şekilde. Yardımcı olursanız çok sevinirim

 

[ÖmerFaruk]

Kopyalacağınız ve boş satırları olduğunu söylediğiniz tabloyu içeren excel dosyanızı paylaşır mısınız?

 

[respecteams]

Dosya bu linke ekledim teşekkürler :=

 

[ÖmerFaruk]

Hangi sayfanın hangi aralığını (dediğiniz boşluklar dahil) hangi sayfaya kopayalacaksınız?

 

[respecteams]

Sayfa 3 ün B3 den G50 ye kadar seçerek Sayfa2 ye B3 G50 hizasında eklemek istiyorum fakat sayfa 3 teki veriler her zaman G50 ye kadar dolu olmayabilir. Yani G50 ye kadar limit var oraya kadar ne kadar veri girildiyse hizası bozulmayacak şekilde Sayfa 2 ye eklenmesini istiyorum. Olan sütundaki verileri değiştirmeden alt alta şekilde yapıştırılmalı. Yani diyelim sayfa 3 yarısına kadar doldu kopyalanacak ve sayfa 2 de en son verinin olduğu yerden devam edecek. Ben basit kopyala yapıstır kodunda tabloyu da seçtiği için yapamadım. İçindeki veriyi alıp yapıstırması lazım.. Eğer yapabilirseniz çok büyük sevap işleyeceksiniz..

 

[ÖmerFaruk]

Aşağıdaki kodu bir Module içince kullanabilirsiniz.

Sub SayfadanAlEnAltaKopyala()
Dim Sh1 As Worksheet, Sh2 As Worksheet, sonSh1 As Integer, sonSh2 As Integer, Wf As WorksheetFunction
    Set Sh1 = Sheets("Sayfa3") 'sayfa3 ismini değiştirirseniz burayı da değiştirin
    Set Sh2 = Sheets("Sayfa2") 'sayfa2 ismini değiştirirseniz burayı da değiştirin
    Set Wf = WorksheetFunction
    sonSh1 = Wf.Min(50, Sh1.Range("B" & Rows.Count).End(3).Row)
    sonSh2 = Sh2.Range("B" & Rows.Count).End(3).Row
    If sonSh1 < 3 Then Exit Sub
    Application.ScreenUpdating = False
    Sh1.Range("B3:G" & sonSh1).Copy
    Sh2.Range("B" & sonSh2 + 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set Sh1 = Nothing: Set Sh2 = Nothing: Set Wf = Nothing
End Sub

 

[respecteams]

Aşağıdaki kodu bir Module içince kullanabilirsiniz.

Sub SayfadanAlEnAltaKopyala()
Dim Sh1 As Worksheet, Sh2 As Worksheet, sonSh1 As Integer, sonSh2 As Integer, Wf As WorksheetFunction
    Set Sh1 = Sheets("Sayfa3") 'sayfa3 ismini değiştirirseniz burayı da değiştirin
    Set Sh2 = Sheets("Sayfa2") 'sayfa2 ismini değiştirirseniz burayı da değiştirin
    Set Wf = WorksheetFunction
    sonSh1 = Wf.Min(50, Sh1.Range("B" & Rows.Count).End(3).Row)
    sonSh2 = Sh2.Range("B" & Rows.Count).End(3).Row
    If sonSh1 < 3 Then Exit Sub
    Application.ScreenUpdating = False
    Sh1.Range("B3:G" & sonSh1).Copy
    Sh2.Range("B" & sonSh2 + 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set Sh1 = Nothing: Set Sh2 = Nothing: Set Wf = Nothing
End Sub

Çok teşekkürler deneyeceğim...

 

[respecteams]

Aşağıdaki kodu bir Module içince kullanabilirsiniz.

Sub SayfadanAlEnAltaKopyala()
Dim Sh1 As Worksheet, Sh2 As Worksheet, sonSh1 As Integer, sonSh2 As Integer, Wf As WorksheetFunction
    Set Sh1 = Sheets("Sayfa3") 'sayfa3 ismini değiştirirseniz burayı da değiştirin
    Set Sh2 = Sheets("Sayfa2") 'sayfa2 ismini değiştirirseniz burayı da değiştirin
    Set Wf = WorksheetFunction
    sonSh1 = Wf.Min(50, Sh1.Range("B" & Rows.Count).End(3).Row)
    sonSh2 = Sh2.Range("B" & Rows.Count).End(3).Row
    If sonSh1 < 3 Then Exit Sub
    Application.ScreenUpdating = False
    Sh1.Range("B3:G" & sonSh1).Copy
    Sh2.Range("B" & sonSh2 + 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set Sh1 = Nothing: Set Sh2 = Nothing: Set Wf = Nothing
End Sub

Çok Sağolun Çalıştı.. Nasıl teşekkür edeceğimi bilemedim..