Çift Tıklanan hücreyi başka bir yere alt alta aktarma

[kayserciyes]

Örnekte I:I Sütünü
Her çift tıklandığında B4 ün üzerine onu değiştirerek aktarıyor
B4 ü Değiştirmeden B4 den aşağıya doğru ilk boş olan yere eklenerek kopyalanmasını sağlaya bilir miyiz

Yarımcı olursanız çok sevinirim şimdiden teşekkür ediyorum

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Son As Long
    If Intersect(Target, [I:I]) Is Nothing Then Exit Sub
    Cancel = True
    Son = Cells(Rows.Count, "B").End(3).Row + 1
    If Son < 4 Then Son = 4
    Cells(Son, "B").Resize(, 3).Value = Target.Resize(, 3).Value
End Sub

 

[kayserciyes]

Korhan Hocam olmuş ancak bir eksiği var
B:B Sutununda boş yer varsa ilk tıklamada orayı dolduracak

Mesela resimde 7.Satır boş ya ilk tıklamada onu doldursun
sonrakinde B10 dan devam edecek

Yani B4 den sonra B Sütununda ilk boş yeri doldurarak devam edecek şekilde düzenleye bilirseniz çok ikrama geçecek

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Son As Long
    If Intersect(Target, [I:I]) Is Nothing Then Exit Sub
    Cancel = True
    Son = Evaluate("=MIN(IF(B4:B1048576="""",ROW(B4:B1048576)))")
    Cells(Son, "B").Resize(, 3).Value = Target.Resize(, 3).Value
End Sub

 

[kayserciyes]

Harika eline sağlık üsdat
tam istediğim gibi olmuş
örnek dosyayı belki biri faydalanır diye ekledim

 

[kayserciyes]

Deneyiniz.

Option Explicit

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Son As Long
    If Intersect(Target, [I:I]) Is Nothing Then Exit Sub
    Cancel = True
    Son = Evaluate("=MIN(IF(B4:B1048576="""",ROW(B4:B1048576)))")
    Cells(Son, "B").Resize(, 3).Value = Target.Resize(, 3).Value
End Sub

Bu makroyu Sayfa1'de çift tıklayınca verileri Sayfa2 ye aktaracak şekilde düzenleye bilir miyiz.

birde o şekilde olanı lazım oldu . yardımınız için teşekkür ederim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Son As Long
    If Intersect(Target, [I:I]) Is Nothing Then Exit Sub
    Cancel = True
    Son = Evaluate("=MIN(IF(Sayfa2!B4:B1048576="""",ROW(Sayfa2!B4:B1048576)))")
    Sheets("Sayfa2").Cells(Son, "B").Resize(, 3).Value = Target.Resize(, 3).Value
End Sub

 

[kayserciyes]

hocam olmuş bir şeyi yazmayı unutmuşum

Tıkladıktan sonra aktif sayfanın Sayfa2 seçili hücreyide o aktarımın yapıldığı hücre yapabilir miyiz

 

[kayserciyes]

Tamam üsdat onuda sizin formülden yola çıkarak ben hallettim
çok teşekkür ederim

 

[kayserciyes]

Hocam kod her tıkladığımda hizalama özellğini değiştiyor hücrenin buda sayfanın yapısını bozuyor
göresel ekledim bir bakabilir misiniz
kodun uyarlanmış şeklinide aşağıya ekliyorum. sayfa adaları falan değişti öncekine göre

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Son As Long
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
Cancel = True
Son = Evaluate("=MIN(IF(Sayfa1!G3:G1048576="""",ROW(Sayfa2!G3:G1048576)))")
Sheets("Sayfa1").Cells(Son, "G").Resize(, 5).Value = Target.Resize(, 5).Value
Sheets("Sayfa2").Select

End Sub

 

[kayserciyes]

tamam hocam sorun yok