Seçilen Satırdaki İstenilen Hücre Verilerini Başka Sayfaya Aktarma

[samet1908]

Merhaba Arkadaşlar,

Benim yapmak istediğim biraz araştırdım bulamadım, Sayfa1 de çift tıklama ile seçilen satıra ait istenilen hücre verisini Sayfa2 ye aktarmak.

Örnek : Sayfa1 'de A2 satırını çift tıklama ile seçtiğimde , C2 , E2, F2, H2 hücrelerindeki verileri Sayfa2'ye aktarmak.

Her seçilen satırlar arasına bir satır boş bırakarak aktarmak.

Konu Hakkında desteğinizi rica ediyorum şimdiden çok teşekkür ederim.

 

[YUSUF44]

Aşağıdaki kodları Sayfa1'in kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) kopyalayıp deneyin. A2:A100 aralığında bir hücreye çift tıkladığınızda Sayfa2'nin A, B, C ve D sütunlarına Sayfa1'in C, E, F ve H sütunlarındaki o satırın verilerini aktarır:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A2:A100]) Is Nothing Then Exit Sub
yeni = Sheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row + 2
If Sheets("Sayfa2").[A1] = "" Then yeni = 1
a = Target.Row
Sheets("Sayfa2").Cells(yeni, "A") = Cells(a, "C")
Sheets("Sayfa2").Cells(yeni, "B") = Cells(a, "E")
Sheets("Sayfa2").Cells(yeni, "C") = Cells(a, "F")
Sheets("Sayfa2").Cells(yeni, "D") = Cells(a, "H")
End Sub

 

[Necdet]

Merhaba,

Aşağıdaki kodları Sayfa1'in kod bölümüne kopyalayıp deneyin ve kendinize uyarlayınız.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    If Intersect(Target, [A:A]) Is Nothing Or Target.Row < 2 Then Exit Sub
   
    Dim Son As Long, _
        Sh2 As Worksheet
   
    Set Sh2 = Sheets("Sayfa2")
   
    Son = Sh2.Cells(Rows.Count, "A").End(3).Row + 2
   
    Range("C" & Target.Row & ":H" & Target.Row).Copy Sh2.Cells(Son, "A")
   
    Set Sh2 = Nothing
   
End Sub

 

[samet1908]

Çok teşekkür ederim hemen deniyorum

 

[samet1908]

Çok teşekkür ederim her iki kod tam istediğim gibi sorunsuz çalıştı, fakat ek olarak şöyle bir sorum olacak. Sayfa1'deki A,B,C,D sutünlarını , Sayfa2'ye aktarırken satır olarak aktarmak istersek alt alt olacak şekilde , hangi kodu çalıştırmam gerekli

 

[YUSUF44]

Aşağıdaki gibi olur sanıyorum. Eğer yine birer satır boşluk olacaksa 3. satırın sonundaki +1 yerine +2 kullanmalısınız:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A2:A100]) Is Nothing Then Exit Sub
yeni = Sheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row + 1
If Sheets("Sayfa2").[A1] = "" Then yeni = 1
a = Target.Row
Sheets("Sayfa2").Cells(yeni, "A") = Cells(a, "A")
Sheets("Sayfa2").Cells(yeni + 1, "A") = Cells(a, "B")
Sheets("Sayfa2").Cells(yeni + 2, "A") = Cells(a, "C")
Sheets("Sayfa2").Cells(yeni + 3, "A") = Cells(a, "D")
End Sub

 

[samet1908]

çok teşekkür ederim tam istediğim gibi oldu