çift tıklama ile hücre seçimi-renk değişimi

[ANKARA1974]

İyi günler, ekteki örnekte belirttiğim gibi herhangi bir hücreye çift tıklama ile ilgili hücrenin seçimini yapma ve rengini değiştirme işlemini yapabilir miyim?

Kolay gelsin.

 

[ANKARA1974]

Dosya ekte

 

[Korhan Ayhan]

Sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

Hücrelere çift tıklayıp denemeler yapın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("G5:N13")) Is Nothing Then
        Cancel = True
        If Target.Row = 5 Then
            Target.Interior.ColorIndex = 6
            Set Bul = Range("B:B").Find(Target & " derecesi", , , xlWhole)
            If Not Bul Is Nothing Then Bul.Select: Bul.Interior.ColorIndex = 6
        Else
            Target.Interior.ColorIndex = 3
            GoTo Son
        End If
    End If
    
    If Not Intersect(Target, Range("G15:I18")) Is Nothing Then
        Cancel = True
        If Target.Row = 15 Then
            Target.Interior.ColorIndex = 6
            Set Bul = Range("B:B").Find(Target & " maliyeti", , , xlWhole)
            If Not Bul Is Nothing Then Bul.Select: Bul.Interior.ColorIndex = 6
        Else
            Target.Interior.ColorIndex = 3
            GoTo Son
        End If
    End If

    If Not Intersect(Target, Range("G20:H22")) Is Nothing Then
        Cancel = True
        If Target.Row = 20 Then
            Target.Interior.ColorIndex = 6
            Set Bul = Range("B:B").Find(Target & " işçiliği", , , xlWhole)
            If Not Bul Is Nothing Then Bul.Select: Bul.Interior.ColorIndex = 6
        Else
            Target.Interior.ColorIndex = 3
            GoTo Son
        End If
    End If
Son:
End Sub

 

[ANKARA1974]

Korhan Bey elinize sağlık, tam istediğim gibi olmuş.

Teşekkür ederim. İyi çalışmalar.

 

[Ömer BARAN]

Merhabalar.

Sanırım aynı sonucu veriyor, alternatif olsun.
Kod'un hareket noktası A sütunundaki hücrenin dolu olup olmaması.
.

[FONT="Arial Narrow"][B]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)[/B]
If ActiveCell.Column > Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Column Then Exit Sub
    If Cells(ActiveCell.Row, 1) <> "" And ActiveCell.Column > 6 And ActiveCell <> "" Then
        If ActiveCell.Interior.ColorIndex = 6 Then
            ActiveCell.Interior.Color = xlNone
            With Cells(ActiveCell.Row + ActiveCell.Column - 6, 2)
                .Activate: .Interior.Color = xlNone
            End With
        Else
            ActiveCell.Interior.ColorIndex = 6
            With Cells(ActiveCell.Row + ActiveCell.Column - 6, 2)
                .Activate: .Interior.ColorIndex = 6
            End With
        End If
    End If
If Cells(ActiveCell.Row, 1) = "" And ActiveCell.Column > 6 And ActiveCell <> "" Then
    If ActiveCell.Interior.ColorIndex = 3 Then
        ActiveCell.Interior.Color = xlNone: Cancel = True
    Else
        ActiveCell.Interior.ColorIndex = 3: Cancel = True
    End If
End If
[B]End Sub[/B][/FONT]

 

[ANKARA1974]

Ömer Bey size de çok teşekkür ederim.
Kodunuz gayet güzel çalışıyor, elinize sağlık.

Kolay gelsin.

Seçim alanında rengi değişen hücreyi daha sonra eski haline nasıl getirebiliriz. Yani kısaca seçimizi nasıl iptal
edebiliriz.

 

[Ömer BARAN]

Tekrar merhaba.

Önceki cevabımdaki kod'u güncelledim, sayfayı yenileyerek kontrol edin.
Çift tıklamayla renklenir, aynı hücreye çift tıklamayla renk kaldırılır.
.

 

[ANKARA1974]

Ömer Bey tekrar teşekkür ederim. Kod tam istediğim gibi çalışıyor.

Elinize sağlık, iyi çalışmalar.

 

[Ömer BARAN]

Ömer Bey tekrar teşekkür ederim. Kod tam istediğim gibi çalışıyor.

Elinize sağlık, iyi çalışmalar.

İyi günler dilerim.