• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 361
  • Last Modified:

Macro for conditional formatting using Worksheet_Calculate()

Hi!

I have a Column K containing values from 0.1 to 20. I would like to color these cells individually based on the value of the cell. The value of the cells in column K is calculated using a forumla (multiplying the cells in column I by the cells in column J).

Everytime I update one of the cells in column I or J the value changes and I would like the cell color to change as well (if applicable).

I have found/modified the attached formula but whenever I expand or collapse groups of rows I get runtime errors.

Thanks :)
Private Sub Worksheet_Calculate()
Dim rngMyRange As Range, rngCell As Range

Set rngMyRange = Range("K8:K100")

'define range, limiting cells to only those with formulae
For Each rngCell In rngMyRange.SpecialCells(xlCellTypeFormulas)

    Select Case rngCell.Value
        Case 0.1 To 5.9:
        rngCell.Interior.Color = RGB(146, 208, 80)
        rngCell.Font.Color = RGB(146, 208, 80)
        Case 6 To 7.9:
        rngCell.Interior.Color = RGB(255, 255, 102)
        rngCell.Font.Color = RGB(255, 255, 102)
        Case 8 To 10:
        rngCell.Interior.Color = RGB(192, 80, 77)
        rngCell.Font.Color = RGB(192, 80, 77)
        Case 10.1 To 15.9:
        rngCell.Interior.Color = RGB(197, 217, 241)
        rngCell.Font.Color = RGB(197, 217, 241)
        Case 16 To 17.9:
        rngCell.Interior.Color = RGB(141, 180, 226)
        rngCell.Font.Color = RGB(141, 180, 226)
        Case 18 To 20:
        rngCell.Interior.Color = RGB(197, 217, 241)
        rngCell.Font.Color = RGB(197, 217, 241)
        Case Else:
        rngCell.Interior.Color = RGB(255, 255, 255)
        rngCell.Font.Color = RGB(255, 255, 255)
    End Select
Next
End Sub

Open in new window

0
cegeland
Asked:
cegeland
  • 2
  • 2
2 Solutions
 
NorieCommented:
Are the values in I and J being changed manually?

ie not due to a formula

If they are you could use a worksheet change event instead of calculate.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range
Dim rngMyRange As Range

    Set rngMyRange = Range("K8:K100")

    If Intersect(Target, rngMyRange.Offset(, -2).Resize(, 2)) Is Nothing Then Exit Sub

        Set rngCell = Target.Offset(, 11 - Target.Column)


        Select Case rngCell.Value
            Case 0.1 To 5.9:
                rngCell.Interior.Color = RGB(146, 208, 80)
                rngCell.Font.Color = RGB(146, 208, 80)
            Case 6 To 7.9:
                rngCell.Interior.Color = RGB(255, 255, 102)
                rngCell.Font.Color = RGB(255, 255, 102)
            Case 8 To 10:
                rngCell.Interior.Color = RGB(192, 80, 77)
                rngCell.Font.Color = RGB(192, 80, 77)
            Case 10.1 To 15.9:
                rngCell.Interior.Color = RGB(197, 217, 241)
                rngCell.Font.Color = RGB(197, 217, 241)
            Case 16 To 17.9:
                rngCell.Interior.Color = RGB(141, 180, 226)
                rngCell.Font.Color = RGB(141, 180, 226)
            Case 18 To 20:
                rngCell.Interior.Color = RGB(197, 217, 241)
                rngCell.Font.Color = RGB(197, 217, 241)
            Case Else:
                rngCell.Interior.Color = RGB(255, 255, 255)
                rngCell.Font.Color = RGB(255, 255, 255)
        End Select

End Sub

Open in new window

0
 
cegelandAuthor Commented:
Thanks for your suggestion. This cleared the error when expanding/collapsing groups.
But when I insert a new row (using attached macro) i now get an error message:
"Application-defined or object-defined error" on the following line:
Set rngCell = Target.Offset(, 11 - Target.Column)
' macro for inserting new row
Sub InsertARow()
     'make new row
    ActiveCell.EntireRow.Insert shift:=xlUp
     'copy the row above
    ActiveCell.Offset(1, 0).EntireRow.Copy Cells(ActiveCell.Row, 1)
    On Error Resume Next
     'clear every cell in the new line that does not have a formula
    ActiveCell.EntireRow.SpecialCells(xlCellTypeConstants, 23).ClearContents
End Sub

Open in new window

0
 
cegelandAuthor Commented:
Actually - I get the same error when I right click in the sheet and click "Insert" as well - so it does not seem to have anything to do with the insert row macro
0
 
NorieCommented:
Add this between line 7 and line 9.
If Target.Cells.Count>1 Then Exit Sub.

Open in new window

0

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now