Sadece seçili hücreleri sayfa 2 de aynı yerlerine kopyalamak.

[arol11]

İyi akşamlar ,iyi çalışmalar
Aktarma ile ilgili olarak bir sorum var.
Sadece mouse ile seçtiğim hücre yada hücreleri Sayfa 2 ye altalta göndermek ,fakat sutun yerleri değişmemeli,sayfa 1 deki yerleri nerdeyse ,nerde başlıyorsa ,nerde bitiyorsa sayfa 2 dede orda olmalı.
Kolay gelsin ,iyi çalışmalar

 

[Seyit Tiken]

Ekli dosyayı inceleyiniz.

Sub Makro1()
If Intersect(ActiveCell, [a1:a100]) Is Nothing Then Exit Sub
If ActiveCell = "" Then Exit Sub
Selection.Copy Destination:=Sayfa2.[a6500].End(3).Offset(1)
MsgBox ActiveCell & " aktarması yapıldı", vbInformation, ActiveCell
End Sub

 

[arol11]

İyi akşamlar,
Sayın Seyit Tiken,sizin dosyanızda aralıkları genişleterek istediğim uygulamayı örneklendirdim.Sayfa 3 deki gibi olmalı.Sayfa 1 deki seçili hücrelerin adresleri nerdeyse sayfa 3 de aynı yere gelmeli.Kodlarınızı biraz daha iyileştirebilmeniz mümkünmü?

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

 

[arol11]

Tamam, Fakat Sayın COST CONTROL,hücreler Sayfa 2 de altalta dizilmeli.Satırlar 1,2,3,4......,sutunlar ise adresleri neyse o şekilde.Yeni dosyada sayfa 3 bakınız.

 

[Korhan Ayhan]

Selamlar,

Örnek dosyadaki kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub AKTAR()
    Set S2 = Sheets("Sayfa2")
    For Each Hücre In Selection
    Satır = S2.Cells(65536, Hücre.Column).End(3).Row + 1
    If H&#252;cre.Value <> "" Then S2.Cells(Sat&#305;r, H&#252;cre.Column) = H&#252;cre.Value
    Next
    Set S2 = Nothing
    MsgBox "SE&#199;&#304;LEN H&#220;CRELER AKTARILMI&#350;TIR.", vbInformation
End Sub

 

[arol11]

Tekrar selamlar,
Fakat şimdide tetris gibi boş olan yerleri doldurarak satırlara kopyalamaya başladı.
Diyeyimki,ilkin a2:b2 aralığını seçip sayfa 2 de : a2:b2 ye kopyaladım.
sonra ikincileyin,d4:e4 aralığını fakat sayfa 2 de d2:e2 aralığına kopyaladı.

 

[Korhan Ayhan]

Selamlar,

Açıklamanızdan şu sonucu çıkarıyorum. Eğer aktarılacak hücre boşsa o hücreye değilse bir alt satıra kopyalanacak. Doğrumudur?

 

[Orion1]

Merhaba.
Ekli dosyayı inceleyiniz.
Not : Sayfa3 Te A:F Aralığına herhangi bir veri girmeyiniz.Çünkü İşlemeri orada yapıp sayfa2 ye aktarıyorum.Sayfa3te a.f arlığını temizliyorum.

Sub Düğme1_Tıklat()
Dim hucre As Range, ilk As Long, son As Long
Dim i As Byte, sonsat As Long
Sheets("Sayfa1").Select
ilk = 65536
Sheets("Sayfa3").Range("A:F").ClearContents
For Each hucre In Selection
    Sheets("Sayfa3").Range(hucre.Address).Value = hucre.Value
    If hucre.Row < ilk Then ilk = hucre.Row
    If hucre.Row > son Then son = hucre.Row
Next
Sheets("Sayfa3").Select
Range(Cells(ilk, "A"), Cells(son, "F")).Copy
Sheets("Sayfa2").Select
For i = 1 To 6
    If Cells(65536, i).End(xlUp).Row > sonsat Then
        sonsat = Cells(65536, i).End(xlUp).Row
    End If
Next
Range("A" & sonsat + 1).PasteSpecial
Application.CutCopyMode = False
MsgBox "İşlem Tamam"
End Sub

 

[Orion1]

Merhaba.
Dosya güncellendi.
Sayfa2'de son satıra göre yapıştırma yapıcak şekilde düzenlendi.

 

[arol11]

Tammamdır,Çok teşekkürler sayın Sezar ve sayın COST CONTROL,
iyi çalışmalar ve iyi hafta sonu dileklerimle.

 

[Orion1]

Rica ederim.
İyi hafta sonları.