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

[Korhan Ayhan]

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]

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]

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]

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


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

[Levent Menteşoğlu]

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.

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

1-Hata durumunda kodun çalışmaya devam etmesini sağlar.
2-sayi değişkenini range yani aralık olarak tanımlar
3-kodun A:E aralığında çalışması sağlanır.
4-A-E aralığındaki sadece sayısal hücreler için döngü oluşturur.
5-deg değişkenine hücredeki sayının A:E aralığındaki sıra değerini hesaplar
6-Tüm hücreleri sırasına göre renklendirir.
7-döngü bitimi

[yurttas]

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]

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

[Korhan Ayhan]

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ı)
B1=23 (Pembe)
C1=18 (Sarı)
D1=15 (Lacivert)
E1=10 (Yeşil)

[Levent Menteşoğlu]

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.

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]

İ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]

İ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]

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]

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

[Ali]

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]

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.



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]

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]

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]

Selamlar,

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

[xxcell]

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


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ıtları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

' İlgili değerin A:E arası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

'İlgili sütuna ilgili rengi ata
Cells(Target.Row, n).Interior.ColorIndex = renk(buyukluk)

Next

End Sub

[Levent Menteşoğlu]

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.

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

1-Hata durumunda kodun çalışmaya devam etmesini sağlar.
2-kodun A:E aralığında çalışması sağlanır.
3-satir değişkenine veri girilen hücrenin satır nosu atanır.
4-A-E aralığındaki sadece sayısal hücreler için döngü oluşturur.
5-deg değişkenine hücredeki sayının A:E aralığındaki sıra değerini hesaplar ve atar.
6-Tüm hücreleri sırasına göre renklendirir.
7-Eğer hücre silinirse renklendirme kaldırılır.
8-döngü bitimi

[last-shoot]

Teşekkürler aradığım bir işlevdi

[mnytextile]

ellerine sağlık

[Önder KOCA]

Daha önce bu konuda formüller verilmiş emeğinize sağlık ancak ben ekteki dosyada gözükdüğü gibi sadece üç renk ve bu renkleri sayıların değerlerine göre tüm sayfaya uygulamak istiyorum mümkünse hücrelerin içinde işaretler değilde sadece renkler bulunmasını istiyorum

Yardımcı olursanız çok sevinirim

Teşekkürler

[leumruk]

Koşullu biçimlendirmeyle yapabilirsiniz.
=f7<0
=f7>0

[leumruk]

Rica ederim. İşinize yaramasına sevindim.

[42asen]

selam herkese,
paylaşmak ne kadar güzel birşey,
arkadaşlar yardımınıza ihtiyacım var.
ekte exel dosyam var açıklamayı orda yaptım yardım ederseniz sevinirim.
saygılar.

[qwertyyy]

Koşullu biçimlendirme ile yapabilirsin

[ciomxx]

merhaba,

hiç formül kullanmadan
*** Home; Styles; Conditional Formatting; Color Scales ***
yaparak da istediğiniz renkte yapabilirsiniz.

[kkaptan36]

Excelde kestiğim faturlar için bir hücrede ödeme tarihini girdim. Başka bir hücrede o tarih geçmiş ise Tarih Geçmiş ya da Ödeme Gününe Var bilgilerini getirmesini sağladım. Ancak şimdi Tarihi Geçmiş olanları renklendirsin istersem nasıl bir formül kullanabilirim.Kullandığım formül aşağıda.
=EĞER(D4="";"";EĞER(TARİH(YIL(D4);AY(D4);GÜN(D4))-TARİH(YIL(BUGÜN());AY(BUGÜN());GÜN(BUGÜN()))<=0;"Tarihi Geçmiş";"Ödeme Gününe Var"))
Şimdi Tarihi Geçmiş olanların hücrelerini örnek KIRMIZI yapmak istiyorum. Yardımcı olabilecek arkadaşlara şimdiden çok teşekkürler.
Saygılarımla,
Kemal

[core2vista]

Merhaba Arkadaşlar,

Vermiş olduğunuz örnekleri inceledim ancak makro ve veri girişlerinin hangi menü altından ne şekilde yapılması gerektiği konusunda bilgim olmadığı için okuduklarımın bir faydası olmadı. Office 2007 denen illet nedense 2003 gibi değil 2003 de her yere giriip çıkıp her türlü işlemi rahatlıkla yapabiliyorduk. Elbette hiç bir mecburiyetiniz yok insanlara yardımcı olmak için elinizden geleni yapıyorsunuz. Sizden ricam bu işlemin nasıl yapılacağını daha detaylıca belirtebilirmisiniz yada hazır bir exel koyun onu inceleyerek nasıl yapıldığını anlamaya çalışayım. Meşakkatten yada uğraştan kaçmıyorum. Tüm forumu baştan sona kadar okuyacak malesef zamanım ve imkanım bulunmuyor örnek olması için kısaca durumu ifade etmek istiyorum - değerlik li -1,3 -3,4 vbg sayısal değer girişlerinde hücrenin yan tarafındaki hücrenin kırmızı olmasını 0 değeri için gri 0 üzeri tüm değerler içinde yeşil olmasını istiyorum bana yardımcı olabilirseniz çok sevinirim.

Yardımınız için teşekkür ederim.

[Korhan Ayhan]

Merhaba,

Forumda "koşullu biçimlendirme" ifadesi ile arama yapınız. Karşınıza birçok örnek çıkacaktır.