Girilen sayısal değere göre hücre renklendirme

Korhan Ayhan · 22 Mayıs 2007

Selamlar,

Arkadaşlar ekteki dosyada [A:E] sütun aralığına girilecek sayısal değerlere göre hücreleri nasıl renklendirebiliriz. Tabi renklendirme şartlı olacak. Girilen sayısal değerler sıralamaya göre renklendirilecektir.

Soruyu çözecek arkadaşlarımızın formül ve makro kodlarının açıklamalarını yazarak yorumda bulunmaları yeni başlayan arkadaşlarımız için faydalı olacaktır.

Not: Başlangıç aşamasında olan arkadaşlarımızda lütfen yorumlarını belirtsinler.

Kolay gelsin.

enderturk · 22 Mayıs 2007

re

aşağıdaki örnekte her hücre değişiminde hücre değerini a1'den e1'e kadar karşılaştırıp eşleşme durumunda 1.satırdaki uygun renk hücre rengi olarak atanmaktadır.

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Value = Range("a1").Value Then Target.Interior.ColorIndex = Range("a1").Interior.ColorIndex
If Target.Value = Range("b1").Value Then Target.Interior.ColorIndex = Range("b1").Interior.ColorIndex
If Target.Value = Range("c1").Value Then Target.Interior.ColorIndex = Range("c1").Interior.ColorIndex
If Target.Value = Range("d1").Value Then Target.Interior.ColorIndex = Range("d1").Interior.ColorIndex
If Target.Value = Range("e1").Value Then Target.Interior.ColorIndex = Range("e1").Interior.ColorIndex

end sub

xxcell · 22 Mayıs 2007

Private Sub Worksheet_Change(ByVal Target As Range)

If IsNumeric(Target.Value) And _
Not Intersect(Target, Columns("A:E")) Is Nothing Then _
Target.Interior.ColorIndex = _
Cells(((Target.Value - 1) Mod 5) + 1, "h").Interior.ColorIndex

End Sub

' Girilen değer sayıysa ve A:E aralığında ise
' Color indexini h sütunundaki ilk 5 hücreye göre
' mod 5 yaparak eşitle

Bundan fazla kısaltamadım :mrgreen:

xxcell · 22 Mayıs 2007

Verdiğim örnek negatif değerlerde hata verdiği için
şu şekilde modifiye ettim.

Kod:

If IsNumeric(Target.Value) And _
Not Intersect(Target, Columns("A:E")) Is Nothing Then _
Target.Interior.ColorIndex = _
Cells((([COLOR="Red"]IIf(Target.Value < 0, -1, 1) * [/COLOR]Target.Value - 1) Mod 5) + 1, "h").Interior.ColorIndex

Levent Menteşoğlu · 22 Mayıs 2007

Aşağıdaki kodu sayfanın kod sayfasına kopyalamalıyız. Sorulan soruda en fazla 5 renk için sınırlama yapıldığından bende buna uydum, yani beş renkten fazla ise fazla olan sayı için renklendirme yapılmayacaktır. Kod her yeni veri girildiğinde tüm renklendirmeyi tekrardan yapar.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim sayi As Range
If Intersect(Target, [a:e]) Is Nothing Then Exit Sub
For Each sayi In [a:e].SpecialCells(xlCellTypeConstants, 1)
deg = WorksheetFunction.Rank(sayi, [a:e], 1)
sayi.Interior.ColorIndex = Cells(deg, "h").Interior.ColorIndex
Next
End Sub
 
[B][COLOR=green]1-Hata durumunda kodun &#231;al&#305;&#351;maya devam etmesini sa&#287;lar.[/COLOR][/B]
[B][COLOR=#008000]2-sayi de&#287;i&#351;kenini range yani aral&#305;k olarak tan&#305;mlar[/COLOR][/B]
[B][COLOR=#008000]3-kodun A:E aral&#305;&#287;&#305;nda &#231;al&#305;&#351;mas&#305; sa&#287;lan&#305;r.[/COLOR][/B]
[B][COLOR=#008000]4-A-E aral&#305;&#287;&#305;ndaki sadece say&#305;sal h&#252;creler i&#231;in d&#246;ng&#252; olu&#351;turur.[/COLOR][/B]
[B][COLOR=#008000]5-deg de&#287;i&#351;kenine h&#252;credeki say&#305;n&#305;n A:E aral&#305;&#287;&#305;ndaki s&#305;ra de&#287;erini hesaplar[/COLOR][/B]
[B][COLOR=#008000]6-T&#252;m h&#252;creleri s&#305;ras&#305;na g&#246;re renklendirir.[/COLOR][/B]
[B][COLOR=#008000]7-d&#246;ng&#252; bitimi[/COLOR][/B]

İdris SERDAR · 22 Mayıs 2007

Sayın leventm müsaade ederlerse,

Hücredeki değeri sildiğimizde beyaz olması amacıyla,

koda;

sayi.Interior.ColorIndex = Cells(deg, "h").Interior.ColorIndex

kodlarından sonra gelmek üzere;

If Intersect(Target, [a:e]) = "" Then Intersect(Target, [a:e]).Interior.ColorIndex = xlNone

kodlarını eklersek iyi olur kanısındayım.

..

Levent Menteşoğlu · 22 Mayıs 2007

Sn yurttas rica ederim, ilaveniz kodun eksikliğini gidermiştir.

Korhan Ayhan · 22 Mayıs 2007

Selamlar,

Arkadaşlar sanırım sorum yanlış anlaşıldı. Sn. leventm beyin çözümüne yakın bir çözüm olacak fakat renklendirme satır bazında sabit kalacak. Yani bir satıra 5 adet değer girdik bu değerler kendi aralarında büyükten küçüğe renklendirilecek. Sayfada verdiğim renklendirmeler örnektir. Yani H sütununun olmadığını düşünerek yanıtlamanızı rica edeceğim.

1. satır için örneklersek;

Girilen değerler;

A1=25 (Kırmız&#305

B1=23 (Pembe)
C1=18 (Sar&#305

D1=15 (Lacivert)
E1=10 (Yeşil)

Levent Menteşoğlu · 22 Mayıs 2007

Bu durumda kodu aşağıdaki gibi düzenleyebiliriz. Bu sefer kod satır bazında düzenlenmiştir. Yani A:E sütununun tümü değil sadece veri girilen satır kendi arasında sıralanmıştır. Yukarıdaki koda tek ilave Sn yurttas'ın hatırlattığı gibi veri silindiğinde hücre renginin kaldırılması ile ilgili satırdır.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim sayi As Range
If Intersect(Target, [a:e]) Is Nothing Then Exit Sub
satir = Target.Row
For Each sayi In Range("a" & satir & ":e" & satir).SpecialCells(xlCellTypeConstants, 1)
deg = WorksheetFunction.Rank(sayi, Range("a" & satir & ":e" & satir), 1)
sayi.Interior.ColorIndex = Cells(deg, "h").Interior.ColorIndex
If Target = "" Then Target.Interior.ColorIndex = xlNone
Next
End Sub

Ali · 22 Mayıs 2007

İki veri aynı olunca renk atlıyor sanırım 10 10 9 8 7 gibi olduğu durumda.

=TOPLA.ÇARPIM((A2<$A$2:$E$2)/EĞERSAY($A$2:$E$2;$A$2:$E$2&""))+1

formülü gibi sıra iki büyüğede 1 değeri verse iyi olur sanırım

Levent Menteşoğlu · 22 Mayıs 2007

Ali' Alıntı:
İki veri aynı olunca renk atlıyor sanırım 10 10 9 8 7 gibi olduğu durumda......

Az önce denedim renk atlamadı.

mavi-mavi-sarı-pembe-kırmızı olarak renklendirdi.

Ali · 22 Mayıs 2007

Levent Bey 10-boş hücre-10-9-8 gibi bir durumdada Rank fonksiyonunun sağlıklı çalışmaması lazım.

Levent Menteşoğlu · 22 Mayıs 2007

Hata vermiyor, ekli dosyada sizde denemeler yapın, belki benim gözden kaçırdığım bir durum vardır.

Ali · 22 Mayıs 2007

Levent Bey anlatmak istediğim örnek dosyanıza uygularsak A1'e 10 B1'i boş bıraktık (orayada 10 yazılabilir) C1'e 10 ve D1 ve E1'e 8 yazdık.Bu durumda D1 ve E1 renklenmiyor.Sürükleyip çoğaltığında bu hata daha çok oluşuyor.10 yazılıp sağa doğru çekildiğinde ikinci ve üçüncü onlar renklenmeyebiliyor.
Eğer hatam varsa düzeltirsiniz.

xxcell · 22 Mayıs 2007

Sayın Cost_Control'un ilave açıklamasından sonra işyerinde vaktim bulamadığım için ödevimi yeni tamamlayabildim. :mrgreen:

Sözüm meclisten dışarı, iş delinin bir kuyuya bir taş atmış çıkartabilirsen çıkart pozisyonuna geldiği için soruya ehemmiyetle eğildim :hihoho:

Aşağıdaki kod şu şekilde çalışır.

Seçimin ilgili satırındaki a:e arasını büyükten küçüğe bir diziye sıralar
Eğer aynı değer bir kaç sütunda mevcutsa sıralamasına göre büyük varsayar.
Metinleride Alfabetik sırasına koyar.

Renklendirmeyi en küçük kırmızı, sırasıyla yeşil, mavi, sarı ve en büyük pembemsi yapar. Hücreye hiçbirşey girili değil ise renklendirmez.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Columns("A:E")) Is Nothing Then Exit Sub

Dim liste(5) As Integer


For derlenen_sutun = 1 To 5

buyukluk = 1
For n = 1 To 5
If Cells(Target.Row, derlenen_sutun).Value > Cells(Target.Row, n) Then buyukluk = buyukluk + 1
Next

eslesme = 1
Do While eslesme = 1
eslesme = 0
For n = 1 To derlenen_sutun - 1
If liste(n) = buyukluk Then
buyukluk = buyukluk + 1
eslesme = 1
End If
Next
Loop

liste(derlenen_sutun) = buyukluk

Next

For n = 1 To 5
If IsEmpty(Cells(Target.Row, n)) Then Cells(Target.Row, n).Interior.ColorIndex = 0 _
Else Cells(Target.Row, n).Interior.ColorIndex = liste(n) + 2
Next

End Sub

Ali · 22 Mayıs 2007

Kuyuya taş atan deli tabirini kullanmanız hiç hoş olmamış burada ne kuyuya taş atan bir deli ne de onu çıkarmaya çalışan birileri var. Burası paylaşım forumu ve günün sorusu ve alternatif çözümler altında en doğrusunu bulmaya çalışıyoruz.

xxcell · 23 Mayıs 2007

xxcell' Alıntı:
Sözüm meclisten dışarı ...

Latife yaptık Sn.Ali,
Size karşı olduğu gibi Sn.Cost_control üstada da saygım sonsuz.
Sorunun güzelliği karşısında HİCİV sanatını kullandım sadece.
Başka bir anlam çıkartırsanız üzülürüm.

Korhan Ayhan · 23 Mayıs 2007

Selamlar,

Arkadaşlar ekteki açıklamalı örneği incelediğinizde sorumun daha net anlaşılacağı kanısındayım.

xxcell · 23 Mayıs 2007

Benim bulabildiğim yegane çözüm şu şekildedir.

1. İlgili satırın A:E arası hücrelerindeki mükerrer kayıtlardan arınmış benzersiz kayıtlardan oluşan bir LİSTE yap
2. İlgili değerin bu LİSTE'deki büyüklüğünü tespit et
3. Büyüklüğe göre renk ata

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Columns("A:E")) Is Nothing Then Exit Sub

Dim liste(5) As String
Dim renk(5) As Integer

'Renk Kartelasini Belirleme
renk(0) = 0
renk(1) = 3
renk(2) = 7
renk(3) = 6
renk(4) = 5
renk(5) = 4


'benzersiz kay&#305;tlar&#305;n listesini alma
liste_ata = 1
For n = 1 To 5
If Not IsEmpty(Cells(Target.Row, n)) And IsNumeric(Cells(Target.Row, n)) Then
    mukerrerlik = False
    For nn = 1 To liste_ata - 1
    If liste(nn) = Cells(Target.Row, n).Value Then mukerrerlik = True
    Next
    If Not mukerrerlik Then
    liste(liste_ata) = Cells(Target.Row, n).Value
    liste_ata = liste_ata + 1
    End If
End If
Next

' &#304;lgili de&#287;erin A:E aras&#305;ndaki Buyuklugunu Tespit Et
For n = 1 To 5

    If Not IsNumeric(Cells(Target.Row, n)) Or IsEmpty(Cells(Target.Row, n)) Then
        buyukluk = 0
    Else
        buyukluk = 1
        For nn = 1 To 5
        If Cells(Target.Row, n) < liste(nn) Then buyukluk = buyukluk + 1
        Next
    End If

'&#304;lgili s&#252;tuna ilgili rengi ata
Cells(Target.Row, n).Interior.ColorIndex = renk(buyukluk)

Next

End Sub

Levent Menteşoğlu · 30 Mayıs 2007

Yukarıda vermiş olduğum koddaki rank fonksiyonu hatalı çalışyordu bu sebeple Sn Ali beyin uyarısı ve önerisi doğrultusunda kodu aşağıdaki gibi revize ettim, bu şekilde gayet güzel çalışıyor, Ali beyede önerisi için teşekkür ederim.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [a:e]) Is Nothing Then Exit Sub
satir = Target.Row
For a = 1 To 5
adr = Cells(satir, a).Address
deg = Evaluate("=SUMPRODUCT((" & adr & "<A" & satir & ":E" & satir & ")/COUNTIF(A" & satir & ":E" & satir & ",A" & satir & ":E" & satir & "&""""))+1")
Cells(satir, a).Interior.ColorIndex = Cells(deg, "h").Interior.ColorIndex
If Cells(satir, a) = "" Then Cells(satir, a).Interior.ColorIndex = xlNone
Next
End Sub
 
[B][COLOR=green]1-Hata durumunda kodun çalışmaya devam etmesini sağlar.[/COLOR][/B]
[B][COLOR=#008000]2-kodun A:E aralığında çalışması sağlanır.[/COLOR][/B]
[B][COLOR=#008000]3-satir değişkenine veri girilen hücrenin satır nosu atanır.[/COLOR][/B]
[B][COLOR=#008000]4-A-E aralığındaki sadece sayısal hücreler için döngü oluşturur.[/COLOR][/B]
[B][COLOR=#008000]5-deg değişkenine hücredeki sayının A:E aralığındaki sıra değerini hesaplar ve atar.[/COLOR][/B]
[B][COLOR=#008000]6-Tüm hücreleri sırasına göre renklendirir.[/COLOR][/B]
[B][COLOR=#008000]7-Eğer hücre silinirse renklendirme kaldırılır.[/COLOR][/B]
[B][COLOR=#008000]8-döngü bitimi[/COLOR][/B]

Girilen sayısal değere göre hücre renklendirme

Korhan Ayhan

Administrator

enderturk

xxcell

xxcell

Levent Menteşoğlu

Administrator

İdris SERDAR

Moderatör

Levent Menteşoğlu

Administrator

Korhan Ayhan

Administrator

Levent Menteşoğlu

Administrator

Ali

Uzman

Levent Menteşoğlu

Administrator

Ali

Uzman

Levent Menteşoğlu

Administrator

Ali

Uzman

xxcell

Ali

Uzman

xxcell

Korhan Ayhan

Administrator

xxcell

Levent Menteşoğlu

Administrator