Worksheet_BeforeDoubleClick birleştirme

[igultekin2000]

iyi günler;
işlemlerimde Worksheet_BeforeDoubleClick özellikli iki ayrı kodu beraber kullanmak istiyorum. Bu şekilde hata veriyor, hatta bu "Worksheet_BeforeDoubleClick " başlıklı 3 veya 4 kod kullanabileceğim işlemler de olabiliyor. Bu başlıklı kodları birleştirmenin püf noktası var mıdır. Teşekkür ederim.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Cancel = True
ActiveCell = ""
For i = 1 To 1
ActiveSheet.Shapes(i).Delete
'Selection.End(xlUp).Select
Selection.Delete Shift:=xlUp 'yukarı sürükle işlemi
Next i
End Sub

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("AKTAR").[I65536].End(xlUp).Offset(1, -8)
Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Delete xlUp
Cancel = True
End Sub

 

[Muzaffer Ali]

Merhaba.

Kodlar aşağıdaki gibi olmalı.
Açıklamaları okursanız faydalı olur.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'If Intersect(Target, Range("I2:I65536")) Is Nothing Then Exit Sub
    'yukarıdaki satır iki kere tıklanan hücre, "I2:I65536" aralığında değilse Exit Sub ile kodlar durduruluyordu,
    'bu satırı aşağıdaki şekilde sadece "Not(Değil)" komutu ile eğer "I2:I65536" aralığı içindeyse kodlar çalışsın şeklinde değiştirilebilir.
       
    'Aşağıdaki kodlar sadece "I2:I65536" aralığında çift tıklanmışsa çalışır.
    If Not Intersect(Target, Range("I2:I65536")) Is Nothing Then
        Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Copy Sheets("AKTAR").[I65536].End(xlUp).Offset(1, -8)
        Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Delete xlUp
        Cancel = True
    End If
   
    'Aşağıdaki kodlar herhangi bir hücreye çift tıkladığınızda çalışır.

    'On Error Resume Next
    'Yukarıdaki satır her ne hata ile karşılaşırsan karşılaş kodları devam ettir anlamına gelir.
    'Bu kod satırını normal çalışma zamanında kullanmak son derece yanlış bir şey. Eğer bir hata varsa onu gidermek lazım yada hata kontrol altına alınmalı ve kullanıcı uyarılmalıdır.
    'Bunu da "On Error Goto" komutu ile yapabilirsiniz.
    'Forumda hata komutu ile ilgili mutlaka makalevardır onları incelemenizi öneririm.
   
    Cancel = True
    ActiveCell = ""
    For i = 1 To 1
        ActiveSheet.Shapes(i).Delete
        'Selection.End(xlUp).Select
        Selection.Delete Shift:=xlUp 'yukarı sürükle işlemi
    Next i
End Sub

 

[igultekin2000]

Merhaba.

Kodlar aşağıdaki gibi olmalı.
Açıklamaları okursanız faydalı olur.

iki özellikte çalışıyor ancak " I:I " sütunda çift tıklayınca norma işlemi yaptığı gibi fazladan " I " sütunun fazladan bir satır daha siliyor. Bunu çözemedim

 

[Muzaffer Ali]

İlk gönderdiğiniz aşağıdaki kodlar hangi hücrelere çift tıklatınca çalışsın?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Cancel = True
ActiveCell = ""
For i = 1 To 1
ActiveSheet.Shapes(i).Delete
'Selection.End(xlUp).Select
Selection.Delete Shift:=xlUp 'yukarı sürükle işlemi
Next i
End Sub

 

[igultekin2000]

İlk gönderdiğiniz aşağıdaki kodlar hangi hücrelere çift tıklatınca çalışsın?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Cancel = True
ActiveCell = ""
For i = 1 To 1
ActiveSheet.Shapes(i).Delete
'Selection.End(xlUp).Select
Selection.Delete Shift:=xlUp 'yukarı sürükle işlemi
Next i
End Sub

" J " sütununda çalışıyo

 

[Muzaffer Ali]

Yukarıda paylaştığım kodlardaki açıklamaları okusaydınız siz de bu sorunu çözebilirdiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("I2:I" & Rows.Count)) Is Nothing Then
        Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Copy Sheets("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" & Rows.Count)) Is Nothing Then
        Cancel = True
        ActiveCell = ""
        For i = 1 To 1
            ActiveSheet.Shapes(i).Delete
            Selection.Delete Shift:=xlUp
        Next i
    End If
End Sub

 

[igultekin2000]

Yukarıda paylaştığım kodlardaki açıklamaları okusaydınız siz de bu sorunu çözebilirdiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("I2:I" & Rows.Count)) Is Nothing Then
        Range(Cells(Target.Row, 1), Cells(Target.Row, 9)).Copy Sheets("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" & Rows.Count)) Is Nothing Then
        Cancel = True
        ActiveCell = ""
        For i = 1 To 1
            ActiveSheet.Shapes(i).Delete
            Selection.Delete Shift:=xlUp
        Next i
    End If
End Sub

Teşekkürler. açıklamaları okudum ve not olarak ta aldım, kod bilgim olmadığı için gönderdiğiniz gibi yapmışım ancak " ElseIf " yazdığınız yeri sadece " If " olarak yazmışım. İlginize tekrar teşekkür ederim. J hücresinde hata verdi " ActiveSheet.Shapes(i).Delete " devre dışı bırakınca sorunsuz çalıştı. Sütun belirttiğiniz için zannedersem bu koda gerek kalmadı, şuan hata vermiyor.

 

[Muzaffer Ali]

İyi çalışmalar kolay gelsin.

 

[tr1066tc]

Merhaba Arkadaşlar,
A sütununda herhangi bir hücreye çift tıkladığımda o hücredeki verinin A1 hücresine; B sütununda herhangi bir hücreye çift tıkladığımda o hücredeki verinin B1 hücresine yazılmasını istiyorum. Bunun için destek olabilir misiniz?

 

[Muzaffer Ali]

Aşağıdaki kodları kullanın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("b2:b" & Rows.Count)) Is Nothing Then
        Range("b1")=target
        Cancel = True
    ElseIf Not Intersect(Target, Range("c2:c" & Rows.Count)) Is Nothing Then
        Range("c1")=target
        Cancel = True
    End If
End Sub