Excel de koşullu hücre boyama

[khanruler]

Herkese selamlar ve iyi bayramlar. Excelde belirli koşullarla belirli hücreleri istediğim renge boyamak istiyorum. Ekte dosyam mevcuttur, açıklama dosyada yapılmıştır yardımlarınızı bekliyorum şimdiden tşkler.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KOŞULLU_RENKLENDİR()
    Dim SAYFA As Worksheet
    Dim X As Long
    Dim BUL1 As Range, BUL2 As Range
    
    For Each SAYFA In Worksheets
    If SAYFA.Name <> "Table" Then
    SAYFA.Range("C11:BU75").Interior.ColorIndex = xlNone
    End If
    Next
    
    Sheets("Table").Select
    
    For X = 2 To [I65536].End(3).Row
    With Sheets("SET " & Cells(X, "I"))
    Set BUL1 = .Range("C11:BU75").Find(Cells(X, "J"), LookAt:=xlWhole)
    If Not BUL1 Is Nothing Then
    Set BUL2 = .Range(.Cells(76, BUL1.Column), .Cells(76, BUL1.Column + 7)).Find(Cells(X, "K"), LookAt:=xlWhole)
    If Not BUL2 Is Nothing Then
    .Range(.Cells(BUL1.Row, BUL2.Column), .Cells(BUL1.Row + .Cells(77, BUL2.Column), BUL2.Column)).Interior.ColorIndex = 3
    End If
    End If
    End With
    Next
    
    Set BUL1 = Nothing
    Set BUL2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[khanruler]

Option Explicit
 
Sub KOŞULLU_RENKLENDİR()
    Dim R As Integer
    Dim L As Integer
    Dim SAYFA As Worksheet
    Dim X As Long
    Dim RRN As Range
    Dim BUL1 As Range, BUL2 As Range
    R = 2
    L = 2
    For Each SAYFA In Worksheets
    If SAYFA.Name <> "Allocation Table" Then
    SAYFA.Range("C6:BX75").Interior.ColorIndex = xlNone
    End If
    Next
    
    Sheets("Allocation Table").Select
    For X = 2 To [I65536].End(3).Row
    With Sheets("SET " & Cells(X, "I"))
    Set RRN = Cells(X, "K")
    If RRN < 13 Then
    R = R + 1
    Set BUL1 = .Range("C10:BU75").Find(Cells(X, "J"), LookAt:=xlWhole)
    If Not BUL1 Is Nothing Then
    Set BUL2 = .Range(.Cells(76, BUL1.Column), .Cells(76, BUL1.Column + 7)).Find(Cells(X, "K"), LookAt:=xlWhole)
    If Not BUL2 Is Nothing Then
    .Range(.Cells(BUL1.Row, BUL2.Column), .Cells(BUL1.Row - 1 + .Cells(77, BUL2.Column), BUL2.Column)).Interior.ColorIndex = R
    End If
    End If
    End If
    
    If RRN = 13 Then
    L = L + 1
    Set BUL1 = .Range("C10:BU75").Find(Cells(X, "J"), LookAt:=xlWhole)
    If Not BUL1 Is Nothing Then
    Set BUL2 = .Range("BX6:BY10").Find(Cells(X, "K"), LookAt:=xlWhole)
    If Not BUL2 Is Nothing Then
    .Range(.Cells(BUL2.Row, BUL1.Column + 1), .Cells(BUL2.Row, BUL1.Column + 18)).Interior.ColorIndex = L
    End If
    End If
    End If
    
    If RRN = 14 Then
    L = L + 1
    Set BUL1 = .Range("C10:BU75").Find(Cells(X, "J"), LookAt:=xlWhole)
    If Not BUL1 Is Nothing Then
    Set BUL2 = .Range("BX6:BY10").Find(Cells(X, "K"), LookAt:=xlWhole)
    If Not BUL2 Is Nothing Then
    .Range(.Cells(BUL2.Row, BUL1.Column), .Cells(BUL2.Row, BUL1.Column + 36)).Interior.ColorIndex = L
    End If
    End If
    End If
    
    If RRN = 15 Then
    L = L + 1
    Set BUL1 = .Range("C10:BU75").Find(Cells(X, "J"), LookAt:=xlWhole)
    If Not BUL1 Is Nothing Then
    Set BUL2 = .Range("BX6:BY10").Find(Cells(X, "K"), LookAt:=xlWhole)
    If Not BUL2 Is Nothing Then
    .Range(.Cells(BUL2.Row, BUL1.Column), .Cells(BUL2.Row, BUL1.Column + 72)).Interior.ColorIndex = L
    End If
    End If
    End If
  
  
    End With
    Next
    
    Set BUL1 = Nothing
    Set BUL2 = Nothing
    
End Sub[/B][/B]

Gönderdiğiniz kodda birkaç değişiklik yaparak istediğimi elde ettim yardımınız için çok teşekkür ederim

 

[zafer481]

Merhaba
rakam girdiğim hücre başkabi hücredeki rakam ile örneğin a1 hücresindeki rakamla aynı ise yeşil farklı ise kırmızı olmasını istiyorum cevap verirseniz sevinirim.

Saygılarımla