• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tıklanan Hücrenin Renklenmesi

  • Konbuyu başlatan Konbuyu başlatan betoncu
  • Başlangıç tarihi Başlangıç tarihi
B

betoncu

Katılım
1 Aralık 2005
Mesajlar
376
Excel Vers. ve Dili
EXCEL 2002
TÜRKÇE
Ekteki dosyada hücreye tıklanınca satır ve sütun kesişimi renklenmektedir.

Ekte göndermiş olduğum mevcut kod üzerinde değişiklik yaparak sadece tıklanan hücrenin renklenmesini nasıl sağlarız?


Mevcut kodlar üzerinde değişiklik yapılmasını istememin sebebi: Örnek dosyadaki kodlar ile oluşturulan dosya kapatıldığında hücrede eski renkler varsa eski renklerin silinmemesi ve satır-sütun kesişimde oluşan rengin hücrenin önceki rengini değiştirmeden yok olmasıdır.
 

Ekli dosyalar

.

Deneyin.

Kod: 
Option Explicit
Const iInternational As Integer = Not (0)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iColor As Integer

On Error Resume Next
iColor = Target.Interior.ColorIndex

If iColor < 0 Then
    iColor = 3
Else
    iColor = iColor + 1
End If

If iColor = Target.Font.ColorIndex Then iColor = iColor + 1

Cells.FormatConditions.Delete

With Range("A" & Target.Cells, Target.Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With


With Range(Target.Offset(Target.Cells, 0).Address & ":" & Target.Offset(0, 0).Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With

End Sub


.
 
Merhaba
Alternatif olsun, belirli bir aralıktaki boş veya dolu hücrelerde tıklanan hücre renklenir.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [a1:t100]) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
[a1:t100].FormatConditions.Delete
Target.FormatConditions.Add Type:=2, Formula1:=iInternational
Target.FormatConditions(1).Interior.ColorIndex = 45
End Sub
 
yurttas' Alıntı:
.

Deneyin.

Kod: 
Option Explicit
Const iInternational As Integer = Not (0)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iColor As Integer

On Error Resume Next
iColor = Target.Interior.ColorIndex

If iColor < 0 Then
    iColor = 3
Else
    iColor = iColor + 1
End If

If iColor = Target.Font.ColorIndex Then iColor = iColor + 1

Cells.FormatConditions.Delete

With Range("A" & Target.Cells, Target.Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With


With Range(Target.Offset(Target.Cells, 0).Address & ":" & Target.Offset(0, 0).Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With

End Sub


.
Genişletmek için tıkla ...

Yurttaş bey teşekkür ederim tam istediğim gibi olmuş. Bir sorum olacak: Mesela A sütunu ile E sütunu arasındaki satırın renklenmesini isteseydik kodda hangi değişikliği yapardık?
 
mersilen' Alıntı:
Merhaba
Alternatif olsun, belirli bir aralıktaki boş veya dolu hücrelerde tıklanan hücre renklenir.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [a1:t100]) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
[a1:t100].FormatConditions.Delete
Target.FormatConditions.Add Type:=2, Formula1:=iInternational
Target.FormatConditions(1).Interior.ColorIndex = 45
End Sub
Genişletmek için tıkla ...

Mersilen bey sizin kodu denedim ama olmadı. İlginiz için teşekkür ederim.
 
Kodlar bende çalışıyor
 

Ekli dosyalar

mersilen' Alıntı:
Kodlar bende çalışıyor
Genişletmek için tıkla ...

Mersilen bey güzel bir çalışma. Size de bir sorum olacak. Aralığın dışına çıkınca burda A1:T100 aralığının dışarısı aralık içerisindeki en son hücrede renk kalıyor. Aralık dışına çıkınca aralık içerisinde tıklanan en son hücredeki rengi kaldırabilirmiyiz?
 
Kodu bunla değiştirin.

Kod: 
Const iInternational As Integer = Not (0)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[COLOR="Red"][a1:t100].FormatConditions.Delete[/COLOR]
If Intersect(Target, [a1:t100]) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
[COLOR="Red"]'[a1:t100].FormatConditions.Delete[/COLOR]
Target.FormatConditions.Add Type:=2, Formula1:=iInternational
Target.FormatConditions(1).Interior.ColorIndex = 45

End Sub


Belirli bir satır için ise
Kod: 
Const iInternational As Integer = Not (0)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[a1:t100].FormatConditions.Delete
If Intersect(Target, [a1:t100]) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
'[a1:t100].FormatConditions.Delete
Range("a" & Target.Row & ":e" & Target.Row).FormatConditions.Add Type:=2, Formula1:=iInternational
Range("a" & Target.Row & ":e" & Target.Row).FormatConditions(1).Interior.ColorIndex = 45

End Sub
 
Son düzenleme:
yurttas' Alıntı:
.

Deneyin.

Kod: 
Option Explicit
Const iInternational As Integer = Not (0)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iColor As Integer

On Error Resume Next
iColor = Target.Interior.ColorIndex

If iColor < 0 Then
    iColor = 3
Else
    iColor = iColor + 1
End If

If iColor = Target.Font.ColorIndex Then iColor = iColor + 1

Cells.FormatConditions.Delete

With Range("A" & Target.Cells, Target.Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With


With Range(Target.Offset(Target.Cells, 0).Address & ":" & Target.Offset(0, 0).Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With

End Sub


.
Genişletmek için tıkla ...

Yurttaş bey içi dolu olan hücre tıklanınca renklenme olmuyor. Nasıl düzeltiriz bu durum acaba?
 
mersilen' Alıntı:
Kodu bunla değiştirin.

Kod: 
Const iInternational As Integer = Not (0)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[COLOR="Red"][a1:t100].FormatConditions.Delete[/COLOR]
If Intersect(Target, [a1:t100]) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
[COLOR="Red"]'[a1:t100].FormatConditions.Delete[/COLOR]
Target.FormatConditions.Add Type:=2, Formula1:=iInternational
Target.FormatConditions(1).Interior.ColorIndex = 45

End Sub
Genişletmek için tıkla ...

Kod: 
Const iInternational As Integer = Not (0)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[COLOR="Red"][a1:t100].FormatConditions.Delete[/COLOR]
If Intersect(Target, [a1:t100]) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
[COLOR="Red"][a1:t100].FormatConditions.Delete[/COLOR]
Target.FormatConditions.Add Type:=2, Formula1:=iInternational
Target.FormatConditions(1).Interior.ColorIndex = 45

End Sub
[/QUOTE]

Mersilen bey teşekkür ederim. Kodu böyle uygulayınca oldu.
 
Yurttaş bey yardımınızı bekliyorum. Acaba sorumu görmediniz mi?
 
Bende Yurttaş hocaya birşey sormak istiyorum.Kodun içinde geçen bu kısımın anlamını açıklar mısınız?Neden koddan önce bunu yazmamız gerekti.
Const iInternational As Integer = Not (0)
Genişletmek için tıkla ...
 
Merhaba,

Ekteki örnek dosyayı inceleyiniz.
 

Ekli dosyalar

Bunların hepsi çok gözel ama en önemli sorun KOŞULLU BİÇİMLENDİRMENİN BOZULMASI.Bende koşullu biçimlendirme olan hücreler var.Hepsini bozuyor.
 
Sayın Ayhan,

Kod gerçekten çok güzel çalışıyor ancak bunu yukardan aşıdan olacak şekilde de düzenleyebilir misiniz...


Yani:
h9n1k.png
 
Merhaba,

Alternatif olarak ekteki örnek dosyayıda kullanabilirsiniz.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst