Koşula bağlı yazı rengi.

[Bora K]

Merhabalar.
Değerli arkadaşlar.

Sayfanın kod bölümünde çalışacak bir koda ihtiyacım var.
Kodun şu şekilde olması istirhamımdır.
(A3:A100) aralığında Herhangi bir değer 10 ve daha fazla ise yazı rengi "Mavi"
(B3:B100) aralığında Herhangi bir değer 15 ve 30 aralığında ise yazı rengi "Kırmızı"
(C3:C100) aralığında Herhangi bir değer 20 ve daha fazla ise yazı rengi "Yeşil"
(D3*D100) aralığında Herhangi bir değer 5 ve 25 aralığında ise yazı rengi "Sarı"

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

 

[raburabu]

merhaba

eki incele Koşullu biçimlendirme ile bunu yapabilirsin.

 

[Ömer]

Merhaba,

Bu şekilde dneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Intersect(Target, [A3:D100]) Is Nothing Then Exit Sub
 
    On Error Resume Next
    With Target
        If .Value = "" Then Exit Sub
        If IsNumeric(.Value) = False Then Exit Sub
        .Font.ColorIndex = 0 'eski rengi siler
        If .Column = 1 Then
            If .Value >= 10 Then .Font.ColorIndex = 5
        End If
        If .Column = 2 Then
            If .Value >= 15 And .Value <= 30 Then .Font.ColorIndex = 3
        End If
        If .Column = 3 Then
            If .Value >= 20 Then .Font.ColorIndex = 14
        End If
        If .Column = 4 Then
            If .Value >= 5 And .Value <= 25 Then .Font.ColorIndex = 6
        End If
    End With
 
End Sub

 

[Mustafa MUTLU]

............

 

[Bora K]

Merhabalar
Sayın Mustafa Bey. sebep her ne olur ise olsun mesajınız için teşekkür ederim.

Sayın raburabu size de teşekkür ederim. Şu uyarıyı yapmak isterim naçizane. Yardım etme
amaçlı dosya eklerken yardım edeceğimiz kişinin versiyonunu göz önünde bulundurur isek şayet
daha iyi olur diye düşünüyorum. Ömer beyin kodu üzerinden gideceğim. Bilgi amaçlıda olsa sizin
dosyayıda görmek isterdim.

Sayın Ömer Bey. Alakanız için çok teşekkür ederim.

Örenk dosyanın kod bölümüne kodu ilave ettim.
İlgili sütunlarda herhangi bir değeri belirttiğim sayıda yazdım. Bu olmadı
sayfayı kapattım yeniden açtım tüm bunlara rağmen kod çalışmadı.
Nerede hata yapıyor olabilirim acaba?

 

[raburabu]

merhaba

özür dilerim örnek ekte

 

[Bora K]

Merhabalar
Özürlük bir durum yok sayın raburabu. Rica ederim.

Alakanız için teşekkür ederim. Dosyayı indirdim.
Lakin siz soruyu yanlış anlamışsınız. Sizin yaptığnız dosyada
sadece rakam olanlar renkleniyor. Benim dosyada ise "herhangi bir değer" ibaresi var.
Bu durumda ilgili veri metinde olabilmektedir. Tekrar teşekkür ederim.

 

[Ömer]

Şartların sağladığına emin oldunuz mu?

Ayrıca şartlarınız sayı olduğu için,

If IsNumeric(.Value) = False Then Exit Sub

ibaresini koymuştum. Bu satırın anlamı; eğer veri metin ise işlem yapma anlamını taşır. Metin değerleriniz varsa bu satırı silmeniz gerekir.

 

[Bora K]

Merhaba Ömer bey.
Raburabu arkadaşımızda yazdıklarımdan rakam ibaresini çıkarttığına göre
bu durumda benim anlatım noksanlığım sözkonusu.

Tekrardan açıklama yapacağım o halde.
Kalın yazılı olanlar ilk mesajımdaki makro için istediğim koşullar idi:

(A3:A100) aralığında Herhangi bir değer 10 ve daha fazla ise yazı rengi "Mavi"
A3:A100 aralığında herhangi bir değer (bu Ömer yazısı yada 555 rakamı olabilir) 10 adetten fazla ise
yazı rengi mavi olsun. 9 ve daha az ise orjinali ne ise o şekilde kalsın.

(B3:B100) aralığında Herhangi bir değer 15 ve 30 aralığında ise yazı rengi "Kırmızı"
b3:b100 aralığında herhangi bir değer (bu Ömer yazısı yada 555 rakamı olabilir) 15 ve 30 aralığında ise
yazı kırmızı olsun. 15 ten küçükse ve 30 dan büyükse orjinali ne ise o şekilde kalsın.

(C3:C100) aralığında Herhangi bir değer 20 ve daha fazla ise yazı rengi "Yeşil"
C3:C100 aralığında herhangi bir değer (bu Ömer yazısı yada 555 rakamı olabilir) 20 adetten fazla ise
yazı rengi mavi olsun. 19 ve daha az ise orjinali ne ise o şekilde kalsın.

(D3*D100) aralığında Herhangi bir değer 5 ve 25 aralığında ise yazı rengi "Sarı"
d3:d100 aralığında herhangi bir değer (bu Ömer yazısı yada 555 rakamı olabilir) 5 ve 25 aralığında ise
yazı sarı olsun. 5 ten küçükse ve 25 den büyükse orjinali ne ise o şekilde kalsın.

Ümit ediyorum ki daha net oldu bu şekilde. Şayet yapılma imkanı var ise bu şekilde bir kod
istemekteyim.

Saygılarımla.

 

[Ömer]

Soruyu anladım.

Sayfanın kod bölümünde istediğinize göre, sadece ilgili aralığa veri girişi yapıldığında çalışan kod istiyorsunuz sanırım ve bu kodun sadece veri girişi yapılan sütundaki değerleri renklendirmesini isiyorsunuz.
Ayırca sadece şarta uyan verinin renklenmesini istiyorsunuz, doğru mu?

 

[Bora K]

Aynen doğru Ömer Bey.

Revize ederek başka çalışmalarımda kullanabilmek için,
Modül versiyonuda olursa ayrıca sevinirim.
İki makro istemiş gibi oluyorum. Şayet çok yeri değişiecek ise
Modül versiyonu kalabilir.

 

[Ömer]

Sadece girilen değere göre çalışan. ( Sayfanın kod bölümüne )

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim alan As Range, say As Long, a As Byte, c As Range, Adr As String
 
    If Intersect(Target, [A3:D100]) Is Nothing Then Exit Sub
 
    With Target
        Set alan = Range(Cells(3, .Column), Cells(100, .Column))
        alan.Font.ColorIndex = 0
        If .Count > 1 Then Exit Sub
        say = WorksheetFunction.CountIf(alan, .Value)
 
        a = 0
        If .Column = 1 Then
            If say >= 10 Then a = 5
        End If
        If .Column = 2 Then
            If say >= 15 And say <= 30 Then a = 3
        End If
        If .Column = 3 Then
            If say >= 20 Then a = 14
        End If
        If .Column = 4 Then
            If say >= 5 And say <= 25 Then a = 6
        End If
    End With
 
    If a > 0 Then
        With alan
            Set c = .Find(Target, , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Cells(c.Row, Target.Column).Font.ColorIndex = a
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    End If
End Sub

-------------------------------------------------------------------------------------------------

Aralıktaki tüm değerleri gözden geçirir. ( Standart Module )

Sub Renklendir()
 
    Dim alan As Range, say As Long, a As Byte, c As Range, Adr As String
    Dim j As Byte, i As Long
 
    Application.ScreenUpdating = False
    Range("A3:D100").Font.ColorIndex = 0
 
    For j = 1 To 4
        Set alan = Range(Cells(3, j), Cells(100, j))
        For i = 3 To 100
            say = WorksheetFunction.CountIf(alan, Cells(i, j))
            a = 0
            If j = 1 Then
                If say >= 10 Then a = 5
            End If
            If j = 2 Then
                If say >= 15 And say <= 30 Then a = 3
            End If
            If j = 3 Then
                If say >= 20 Then a = 14
            End If
            If j = 4 Then
                If say >= 5 And say <= 25 Then a = 6
            End If
 
            If a > 0 Then
                With alan
                    Set c = .Find(Cells(i, j), , xlValues, xlWhole)
                    If Not c Is Nothing Then
                        Adr = c.Address
                        Do
                            Cells(c.Row, j).Font.ColorIndex = a
                            Set c = .FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> Adr
                    End If
                End With
            End If
        Next i
    Next j
 
    Application.ScreenUpdating = True
 
End Sub

 

[Bora K]

Ömer Bey.
Çok çok teşekkür ederim.
Herşey gönülünzce olsun inşallah.