Double clik birleştirme

[igultekin2000]

iyi günler;
çeşitli versiyonlar denememe rağmen sorunu çözemedim. aynı çalışma sayfasında " BeforeDoubleClick " kullanmak istiyorum

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("I2:I65536")) Is Nothing Then Exit Sub
Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Copy Sheets("FIS_AKTAR").[I65536].End(xlUp).Offset(1, -8)
Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Delete xlUp
Cancel = True
End Sub

2.kod

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim son As Long
    son = Cells(Rows.Count, "J").End(xlUp).Row
    If Intersect(Target, Range("J2:J" & son)) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    [B1] = Target
End Sub

aynı çalışma sayfasının kod kısmına adapte etmek istiyorum, teşekkürler.

 

[Muzaffer Ali]

Merhaba.
Deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim son As Long
    son = Cells(Rows.Count, "J").End(xlUp).Row
    If Not Intersect(Target, Range("I:I")) Is Nothing Then
        Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Copy Sheets("FIS_AKTAR").[I65536].End(xlUp).Offset(1, -8)
        Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Delete xlUp
        Cancel = True
    ElseIf Not Intersect(Target, Range("J2:J" & son)) Is Nothing And Target <> "" And Target.Count = 1 Then
        [B1] = Target
    End If
End Sub

 

[igultekin2000]

Merhaba.
Deneyiniz.

Sorunsuz çalışıyor, Teşekkür ederim. iyi çalışmalar

 

[Muzaffer Ali]

Rica ederim. İyi çalışmalar.