Dolu hücreleri aktarma

[Mdemir63]

Selamlar,
Arkadaşlar ekteki dosyamda Sayfa2 deki değişik hücrelerdeki verileri Sayfa1 e A3 hücresinden başlayarak aktarmasını yaptırmak istiyorum. Ama dosyamdaki mevcut kodlarla yaptıramadım.

Saygılar

 

[Mdemir63]

Selamlar,

Arkadaşlar önceki dosyamı değiştirdim . Yeni dosya ekte
Yapmak istediğimi kısaca tekrar anlatmak gerekirse; Sayfa 2 de bulunan değişik yerlerdeki verileri, Sayfa 1 de A3 hücresinden başlayarak aşağı doğru aktarması . Mevcut kodlarda nereleri değiştirmem gerekir .

Saygılar

Mevcut Kod:
Sub AKTAR()
Onay = MsgBox("Bilgileri aktarmak istiyor musunuz ?", vbYesNo + vbExclamation, "ONAY")
If Onay = vbNo Then Exit Sub
If Onay = vbYes Then
Set SG = Sheets("Sayfa2")
For X = 2 To Sheets.Count
Satır = 2
Sheets(X).[A2:B65536].ClearContents
For Y = 3 To SG.[A65536].End(3).Row
If SG.Cells(Y, X) <> "" Then
Sheets(X).Cells(Satır, 1) = SG.Cells(Y, 1)
Sheets(X).Cells(Satır, 2) = SG.Cells(Y, X)
Satır = Satır + 1
End If
Next
Next
End If
MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Mdemir63]

Selamlar,

dosyamdaki kodları istediğimi yapacak şekilde revize edebilecek arkadaşlarımız varmı ?

Şimdiden teşekkürler

Saygılar

 

[Mdemir63]

Arkadaşlar konuyla ilgili hiç bir fikri olan yokmu acaba?

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub AKTAR()
    Onay = MsgBox("Bilgileri aktarmak istiyor musunuz ?", vbYesNo + vbExclamation, "ONAY")
    If Onay = vbNo Then Exit Sub
    If Onay = vbYes Then
        Set SG = Sheets("Sayfa2")
        Satir = 3
        Sheets("Sayfa1").Range("A3:A" & Rows.Count).ClearContents
        
        For X = 3 To SG.Cells(Rows.Count, 1).End(3).Row
            If SG.Cells(X, 1) <> "" Then
            Sheets("Sayfa1").Cells(Satir, 1) = SG.Cells(X, 1)
            Satir = Satir + 1
            End If
        Next
    End If
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Mdemir63]

Selamlar,

Korhan hocam elinize sağlık çok teşekkür ederim.

Saygılar