Hücre Renklendirme

[BBBBuRaKKKK]

Merhaba,

Bu tabloda her şahsın 3 satırlık bilgileri var.

Bu 3 satırların SAYI1 ve SAYI2 sütunlarını ilk 2 satırını sarı 3. satırlarınıda kırmızıya boyamak istiyorum.

Yani

Satır 1 ve 2 SARIYA

Satır 3 KIRMIZIYA

Satır 4 ve 5 SARIYA

Satır 6 KIRMIZIYA

.
.
.

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodu kullanın.

Sub Test()
    Dim Bak As Long
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 3
        Range("C" & Bak & ":D" & Bak + 1).Interior.Color = 65535
        Range("C" & Bak + 2 & ":D" & Bak + 2).Interior.Color = 255
    Next
End Sub

 

[Merhum İdris SERDAR]

.

Dosyanız ekte.

.

 

[BBBBuRaKKKK]

İlginize çok teşekkür ederim İdris Bey ve Muzaffer Bey

 

[BBBBuRaKKKK]

Tekrar Merhaba Muzaffer bey bu koda ilave olaraktan

Sadece

- Sarı boyanan hücreler için 0,0000115740740740741 ile 0,333321759259259 arasındakilerini

- Kırmızı boyanan hücreler için 0,40625 ile 0.75 aralığında olanları boyatmamız mümkün mü ?

 

[Muzaffer Ali]

Sub Test()
    Dim Bak As Long
    Range("C1:D" & Rows.Count).Interior.Pattern = xlNone
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 3
        If Range("C" & Bak & ":D" & Bak) >= 1.15740740740741E-05 And Range("C" & Bak & ":D" & Bak) <= 0.333321759259259 Then _
        Range("C" & Bak & ":D" & Bak).Interior.Color = 65535
        
        If Range("C" & Bak & ":D" & Bak) >= 1.15740740740741E-05 And Range("C" & Bak & ":D" & Bak) <= 0.333321759259259 Then _
        Range("C" & Bak + 1 & ":D" & Bak + 1).Interior.Color = 65535
        
        If Range("C" & Bak & ":D" & Bak) >= 0.40625 And Range("C" & Bak & ":D" & Bak) <= 0.75 Then _
        Range("C" & Bak + 2 & ":D" & Bak + 2).Interior.Color = 255
    Next
End Sub

 

[BBBBuRaKKKK]

Bu kısımda hata almaktayım Muzaffer Bey
Type mismatch hatası

 

[Muzaffer Ali]

Aşağıdaki kod da olmazsa dosyanızı ekleyin üzerinde bakayım.

Sub Test()
    Dim Bak As Long
    Dim BakR As Range
    Range("C1:D" & Rows.Count).Interior.Pattern = xlNone
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 3
        For Each BakR In Range("C" & Bak & ":D" & Bak + 1)
            If BakR >= 1.15740740740741E-05 And BakR <= 0.333321759259259 Then _
            BakR.Interior.Color = 65535
        Next
        For Each BakR In Range("C" & Bak + 2 & ":D" & Bak + 2)
            If BakR >= 1.40625 And BakR <= 0.75 Then _
            BakR.Interior.Color = 255
        Next
    Next
End Sub

 

[BBBBuRaKKKK]

Doğru çalışıyor teşekkür ederim elinize sağlık, ilave sütun ekleyince ayrı bir sub açıp mı yapmam gerekiyor pratik bir yolu var mı ? çok yordum kusura bakmayın sizi

 

[Muzaffer Ali]

Altı çizili kırmızı satırdaki C ve D sütun başlığıdır. Eğer C ile E arası olacaksa D yerine E yazmalısınız.
Ama bu durumda E sütununda da rakam kontrol edilir eğer belirttiğiniz aralıktaysa renklendirir.
Sub Test()
Dim Bak As Long
Dim BakR As Range
Range("C1: D" & Rows.Count).Interior.Pattern = xlNone
For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 3
For Each BakR In Range("C" & Bak & ": D" & Bak + 1)
If BakR >= 1.15740740740741E-05 And BakR <= 0.333321759259259 Then _
BakR.Interior.Color = 65535
Next
For Each BakR In Range("C" & Bak + 2 & ": D" & Bak + 2)
If BakR >= 1.40625 And BakR <= 0.75 Then _
BakR.Interior.Color = 255
Next
Next
End Sub

Not: ": D" şeklinde ortaya bir boşluk eklemek zorunda kaldım aksi halde emoji çıkıyor. Siz kendi kodlarınızda boşluğu silmelisiniz. Aynı 8. mesajdaki koddaki gibi olmalı

 

[BBBBuRaKKKK]

Harika !! Teşekkürler elinize sağlık