Kopyalama kodlarında sınırlama

[excellcan]

Set s1 = Sheets("Sayfa3")
j = s1.[A1048576].End(3).Row + 1
If j < 21 Then j = 21
Selection.Copy s1.Range("A" & j)

Forumda emeği geçen tüm arkadaşlara merhaba. Arkadaşlar yukardaki kodla sayfa 1 de herhangi bir alandan seçtiğim verileri sayfa3 'e aktarabiliyorum. Dün bütün gün uğraşmama rağmen yapmak istediğim bazı sınırlamaların kodlarını yazamadım. Yapmak istediklerim şunlar. 1- Sayfa3 de aktarma yaptığım alan A21:A30 aralığı. Ben sayfa1 de on satırlık bir alandan fazlasını seçmişsem bunun ilk on satırını seçecek ve sayfa3'e aktaracak. Hiç bir şekilde sayfa3 de A30'un altına aktarma yapmayacak. 2- Varsayalım ki sayfa 3 de A21:A30 aralığında bir iki boşluk var. Mesela A23 ve A27 boş diğerleri dolu olsun. Ben sayfa1 de on satırlık bir alan yada fazlasını seçmiş olursam bunun ilk iki satırını seçecek sayfa 3 de boş olan hücrelere yazacak. Hiç bir şekilde sayfa3 de A30'un altına aktarma yapmayacak. Başka bir deyişle sayfa3 A21:A30 aralığında ne kadar boşluk varsa sayfa1 de seçmiş olduğum verileri o kadar seçecek ve boş hücrelere aktaracak. Umarım karışık bir anlatım olmamıştır. İlgilenen arkadaşlara şimdiden teşekkürler.

 

[Ferhat Pazarçevirdi]

Merhabalar

Aşağıdaki kodu, Sayfa1'de oluşturacağınız bir butona bağlayınız ve çalıştırınız.

Sub Aktarma()
    
    Dim rng As Range
    Dim hcr As Range
    Dim rngHedef As Range
    Dim iSecimYukseklik As Integer
    Dim i As Integer
    
    Set rngHedef = Sheets("Sayfa3").Range("A21:A30")
    
    If TypeOf Selection Is Range Then
        Set rng = Selection
        iSecimYukseklik = rng.Rows.Count
    Else
        MsgBox "Bir aralık seçmelisiniz", vbCritical, "Seçimde hata"
    End If
    
    For Each hcr In rngHedef.Cells
        If Len(hcr) = 0 Then
            i = i + 1
            If i <= iSecimYukseklik Then
                hcr = rng.Cells(i, 1)
            Else
                Exit For
            End If
        End If
    Next
    
End Sub

.

 

[excellcan]

Hocam işte budur. Süper olmuş emeğinize sağlık.

 

[excellcan]

Merhabalar

Aşağıdaki kodu, Sayfa1'de oluşturacağınız bir butona bağlayınız ve çalıştırınız.

Sub Aktarma()
    
    Dim rng As Range
    Dim hcr As Range
    Dim rngHedef As Range
    Dim iSecimYukseklik As Integer
    Dim i As Integer
    
    Set rngHedef = Sheets("Sayfa3").Range("A21:A30")
    
    If TypeOf Selection Is Range Then
        Set rng = Selection
        iSecimYukseklik = rng.Rows.Count
    Else
        MsgBox "Bir aralık seçmelisiniz", vbCritical, "Seçimde hata"
    End If
    
    For Each hcr In rngHedef.Cells
        If Len(hcr) = 0 Then
            i = i + 1
            If i <= iSecimYukseklik Then
                hcr = rng.Cells(i, 1)
            Else
                Exit For
            End If
        End If
    Next
    
End Sub

.

Ferhat hocam bu kodlara yukardaki şartlar aynı kalmak kaydıyla şöyle bir ekleme yapılabilir mi ? Ben sayfa1 de süzme yaptığım değerleri de aktarmak istedim. Fakat olmadı. Süzdüğüm değerleri de aynı şartlarda aktarabilir miyiz?