VBA loop for same colums but different rows

user_12481521 0
Viewed 64

I have this formula that colors a cell according to the colors of 2 other cells:

Sub RatingColor()
If range("F13").Interior.Color = RGB(146, 208, 80) And range("H13").Interior.Color = RGB(146, 208, 80) Then
 range("J13").Interior.Color = RGB(146, 208, 80)
 ElseIf range("F13").Interior.Color = RGB(255, 255, 0) And range("H13").Interior.Color = RGB(146, 208, 80) Then
 range("J13").Interior.Color = RGB(146, 208, 80)
 
 ElseIf range("F13").Interior.Color = RGB(255, 192, 0) And range("H13").Interior.Color = RGB(146, 208, 80) Then
 range("J13").Interior.Color = RGB(255, 255, 0)
 ElseIf range("F13").Interior.Color = RGB(255, 255, 0) And range("H13").Interior.Color = RGB(255, 255, 0) Then
 range("J13").Interior.Color = RGB(255, 255, 0)
 ElseIf range("F13").Interior.Color = RGB(146, 208, 80) And range("H13").Interior.Color = RGB(255, 255, 0) Then
 range("J13").Interior.Color = RGB(255, 255, 0)
 
 ElseIf range("F13").Interior.Color = RGB(255, 192, 0) And range("H13").Interior.Color = RGB(255, 255, 0) Then
 range("J13").Interior.Color = RGB(255, 192, 0)
 ElseIf range("F13").Interior.Color = RGB(146, 208, 80) And range("H13").Interior.Color = RGB(255, 192, 0) Then
 range("J13").Interior.Color = RGB(255, 192, 0)
 ElseIf range("F13").Interior.Color = RGB(255, 255, 0) And range("H13").Interior.Color = RGB(255, 192, 0) Then
 range("J13").Interior.Color = RGB(255, 192, 0)
 
 ElseIf range("F13").Interior.Color = RGB(255, 192, 0) And range("H13").Interior.Color = RGB(255, 192, 0) Then
 range("J13").Interior.Color = RGB(255, 0, 0)
 ElseIf range("F13").Interior.Color = RGB(146, 208, 80) And range("H13").Interior.Color = RGB(255, 0, 0) Then
 range("J13").Interior.Color = RGB(255, 0, 0)
End If
End Sub

For example:

If F13 = orange and H13 = green, then J13= yellow.

enter image description here

The next step would be that cell J14 turn to orange because green + orange = orange. And so on and so forth. What I need is to create a loop that goes through the same columns in different rows checking those conditions and acts on the Jn cell in the following rows.

Thanks.

for-loop vba excel loops
3 Answers
' determine rules (+ - prefix for matching start, G - green, Y - yellow, O - orange, R - red)
Const RULEZ = "+GGG+YGG+OGY+YYY+GYY+OYO+GOO+YOO+OOR+GRR"

Const TESTRANGE = "F13:F16" ' in first column with colors

Sub RatingColor()   ' loop
    Dim cl As Range
    For Each cl In Range(TESTRANGE)
        setColor cl, cl.Offset(0, 2), cl.Offset(0, 4)   ' source clolors #1, #2 and destination cell
    Next
End Sub

Sub setColor(c1 As Range, c2 As Range, c3 As Range) ' source colors #1, #2 and destination cell
    Dim tColor ' Variant, initial value is Empty
    
    s = "+" & getColorChar(c1) & getColorChar(c2)   ' make the signature of 3 chars such as "+GY" for match in RULEZ
    If Len(s) = 3 Then
        pos = InStr(RULEZ, s)
        If pos > 0 Then clr = Mid(RULEZ, pos + 3, 1) ' if signature found in RULEZ then get next char - target color
    End If

    Select Case clr ' target color value from color letter
        Case "G"
            tColor = RGB(146, 208, 80)
        Case "Y"
            tColor = RGB(255, 255, 0)
        Case "O"
            tColor = RGB(255, 192, 0)
        Case "R"
            tColor = RGB(255, 0, 0)
    End Select
    
    If Not IsEmpty(tColor) Then c3.Interior.Color = tColor
End Sub

Function getColorChar(c As Range) As String ' color letter from color value
    Select Case c.Interior.Color
        Case RGB(146, 208, 80)
            getColorChar = "G"
        Case RGB(255, 255, 0)
            getColorChar = "Y"
        Case RGB(255, 192, 0)
            getColorChar = "O"
        Case RGB(255, 0, 0)
            getColorChar = "R"
    End Select
End Function
user_150353140

Apply Rating Color

  • The procedures RatingColor1 and RatingColor2 illustrate how to utilize the procedure applyRatingColor.
Option Explicit

Sub RatingColor1()
    applyRatingColor ActiveSheet, 13, "F", 2 ' or...
    'applyRatingColor ActiveSheet, 13, 6, 2
End Sub

Sub RatingColor2()

    Const First As Long = 13
    Const Last As Long = 30 ' usually calculated

    Dim ws As Worksheet: Set ws = ActiveSheet ' You can do better.

    Application.ScreenUpdating = False
  
    Dim r As Long
    For r = First To Last
        applyRatingColor ws, r, "F", 2 ' or...
        'applyRatingColor ws, r, 6, 2
    Next r

    Application.ScreenUpdating = True

End Sub

Sub applyRatingColor( _
        ByVal ws As Worksheet, _
        ByVal RowNumber As Long, _
        ByVal FirstColumn As Variant, _
        ByVal ColumnOffset As Long)

    Dim cDat(0 To 9) As Variant
    cDat(0) = VBA.Array(RGB(146, 208, 80), RGB(146, 208, 80), RGB(146, 208, 80))
    cDat(1) = VBA.Array(RGB(255, 255, 0), RGB(146, 208, 80), RGB(146, 208, 80))
    cDat(2) = VBA.Array(RGB(255, 192, 0), RGB(146, 208, 80), RGB(255, 255, 0))
    cDat(3) = VBA.Array(RGB(255, 255, 0), RGB(255, 255, 0), RGB(255, 255, 0))
    cDat(4) = VBA.Array(RGB(146, 208, 80), RGB(255, 255, 0), RGB(255, 255, 0))
    cDat(5) = VBA.Array(RGB(255, 192, 0), RGB(255, 255, 0), RGB(255, 192, 0))
    cDat(6) = VBA.Array(RGB(146, 208, 80), RGB(255, 192, 0), RGB(255, 192, 0))
    cDat(7) = VBA.Array(RGB(255, 255, 0), RGB(255, 192, 0), RGB(255, 192, 0))
    cDat(8) = VBA.Array(RGB(255, 192, 0), RGB(255, 192, 0), RGB(255, 0, 0))
    cDat(9) = VBA.Array(RGB(146, 208, 80), RGB(255, 0, 0), RGB(255, 0, 0))
 
    Dim rDat As Variant
    rDat = VBA.Array(ws.Cells(RowNumber, FirstColumn), _
        ws.Cells(RowNumber, FirstColumn).Offset(, ColumnOffset), _
        ws.Cells(RowNumber, FirstColumn).Offset(, ColumnOffset * 2))

    Dim n As Long
    For n = 0 To UBound(cDat)
        If rDat(0).Interior.Color = cDat(n)(0) _
                And rDat(1).Interior.Color = cDat(n)(1) Then
            rDat(2).Interior.Color = cDat(n)(2)
            Exit For
        End If
    Next n

End Sub
user_98140690

What about if we replace all the Range("") statements with Cells(row, col) statements. Is it more obvious how to achieve your objective?

Option Explicit

Sub RatingColor()
    
    With Worksheets("Sheet1")
    
        If .Cells(13, 6).Interior.Color = RGB(146, 208, 80) And .Cells(13, 8).Interior.Color = RGB(146, 208, 80) Then
            .Cells(13, 10).Interior.Color = RGB(146, 208, 80)
        
        ElseIf .Cells(13, 6).Interior.Color = RGB(255, 255, 0) And .Cells(13, 8).Interior.Color = RGB(146, 208, 80) Then
            .Cells(13, 10).Interior.Color = RGB(146, 208, 80)
            
        ElseIf .Cells(13, 6).Interior.Color = RGB(255, 192, 0) And .Cells(13, 8).Interior.Color = RGB(146, 208, 80) Then
            .Cells(13, 10).Interior.Color = RGB(255, 255, 0)
        
        ElseIf .Cells(13, 6).Interior.Color = RGB(255, 255, 0) And .Cells(13, 8).Interior.Color = RGB(255, 255, 0) Then
            .Cells(13, 10).Interior.Color = RGB(255, 255, 0)
        
        ElseIf .Cells(13, 6).Interior.Color = RGB(146, 208, 80) And .Cells(13, 8).Interior.Color = RGB(255, 255, 0) Then
            .Cells(13, 10).Interior.Color = RGB(255, 255, 0)
            
        ElseIf .Cells(13, 6).Interior.Color = RGB(255, 192, 0) And .Cells(13, 8).Interior.Color = RGB(255, 255, 0) Then
            .Cells(13, 10).Interior.Color = RGB(255, 192, 0)
        
        ElseIf .Cells(13, 6).Interior.Color = RGB(146, 208, 80) And .Cells(13, 8).Interior.Color = RGB(255, 192, 0) Then
            .Cells(13, 10).Interior.Color = RGB(255, 192, 0)
        
        ElseIf .Cells(13, 6).Interior.Color = RGB(255, 255, 0) And .Cells(13, 8).Interior.Color = RGB(255, 192, 0) Then
            .Cells(13, 10).Interior.Color = RGB(255, 192, 0)
            
        ElseIf .Cells(13, 6).Interior.Color = RGB(255, 192, 0) And .Cells(13, 8).Interior.Color = RGB(255, 192, 0) Then
            .Cells(13, 10).Interior.Color = RGB(255, 0, 0)
        
        ElseIf .Cells(13, 6).Interior.Color = RGB(146, 208, 80) And .Cells(13, 8).Interior.Color = RGB(255, 0, 0) Then
            .Cells(13, 10).Interior.Color = RGB(255, 0, 0)
        
        End If
    
    End With
    
End Sub
user_38170680
Related