Conditional Formatting with VBA getting incorrect row values in final CF

[welshgasman]

Hi all,
I had some help using Conditional Formatting in VBA in this thread. VBA apply conditional formatting

I have still not been able to work out what is going on.
Does anyone have any clue please.

Basically Excel is replacing my target range with a very high number, near the limit of Excel rows.
I have walked through the code and checked that the values from the worksheet cells are passed in correctly, but those high numbers still get in there.

If I cannot get to the bottom of it, would anyone know a workaround?

Sub Set_CF()
' https://www.mrexcel.com/board/threads/vba-apply-conditional-formatting.1220882/
' Created: 20221101
' By:      HaHoBe
' Version: 1
' Updated: 20221117
' Reason:  allowing more than one condition for CF
    Dim lngCounter As Long
    Dim rngToWork As Range
    Dim ws As Worksheet
    Dim wsCond As Worksheet
    Dim wsTarg As Worksheet

    On Error GoTo Error_CF
    Set wsCond = Worksheets("CF")
    If wsCond Is Nothing Then GoTo end_here
    On Error GoTo 0

    'Remove old conditional formatting
    '  For Each Ws In ThisWorkbook.Worksheets
    '    If Ws.Name <> wsCond.Name Then
    '      Ws.Cells.FormatConditions.Delete
    '    End If
    '  Next Ws
    ' Clear formatting
    '/// I would recommend to use the tab name here instead of any position
    Worksheets("SF66OEK").Cells.FormatConditions.Delete
    Worksheets("Passengers").Cells.FormatConditions.Delete
   
    'Set new formatting
    For lngCounter = 2 To wsCond.Range("A" & Rows.Count).End(3).Row
        On Error GoTo Error_CF
        Set wsTarg = Worksheets(wsCond.Cells(lngCounter, 1).Value)
        If wsTarg Is Nothing Then GoTo end_here
        Set rngToWork = wsTarg.Range(wsCond.Cells(lngCounter, 6).Value, wsCond.Cells(lngCounter, 7).Value)
        If rngToWork Is Nothing Then GoTo end_here
        On Error GoTo 0
        With rngToWork
            Debug.Print wsCond.Cells(lngCounter, 3).Value
            .FormatConditions.Add xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value
            .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Font.ColorIndex = wsCond.Cells(lngCounter, 5).Value
            .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Interior.Color = wsCond.Cells(lngCounter, 4).Value
            .FormatConditions(wsCond.Cells(lngCounter, 8)).StopIfTrue = False

        End With
    Next lngCounter

end_here:
    If wsCond Is Nothing Then
        MsgBox "Check the name of the sheet with the parameters.", vbExclamation, "Name of sheet with parameters"
    ElseIf wsTarg Is Nothing Then
        MsgBox "Check the name of the target sheet", vbExclamation, "Could not find sheet"
    ElseIf rngToWork Is Nothing Then
        MsgBox "Could not build a range to work on, please check addresses.", vbExclamation, "Problems building range"
    End If

    Set rngToWork = Nothing
    Set wsTarg = Nothing
    Set wsCond = Nothing
    MsgBox "CF now reset on " & ActiveWorkbook.Name
    Exit Sub
Error_CF:
    MsgBox "Error in CF module " & Err.Description & " - " & Err.Number
    Resume end_here
End Sub

 

[welshgasman]

You can apply multiple conditional formats as long as they don't contradict each other. If you have two rules that both apply a fill colour for example, obviously they can't both work. But if one uses a fill colour and another a font colour, then they can both apply at once (unless you used Stop if true).

Well I started off just using Font Colour, but I do have 5 rules on one sheet.
I could check to see if a cell has a value before trying to apply the format.
I have already added two more columns for Bold and Italic.

Thank you both. AT least you got to the bottom of it.

 

[Joe4]

You are welcome.
Glad we were able to help!

 

[welshgasman]

Sorry for the delay in any reply.
I did not get any notifications of any new posts.

Despite me having never messed with the preferences.

 

[welshgasman]

Well, there it is! Nice detective work, Rory.

So he would need to write the rules to only change the things he wants changed (either Font.ColorIndex or Interior.Color), but not both for each and every rule or else that last one is going to win and overwrite everything prior to it.

welshgasman,
Maybe add two new columns, True/False fields for Update Font and Update Background, then code it into your script to only apply that part for each formula if those fields are True.

Had a think about this when I woke up this morning. Sad I know.
It is actually the first rule that gets the honours. I gues that is why we have to delete the rules first, else we could just overwrite the rules.

I might, just might amend it to set one facet of the CF, be it FontColor, ColorIndex, Bold or Italic. I can do that by leaving the CF cell empty and test for that.

 

[welshgasman]

OK, I think I can live with this for the time being.

Thanks again for the help.

Which poduces

Sub Set_CF()
' https://www.mrexcel.com/board/threads/vba-apply-conditional-formatting.1220882/
' Created: 20221101
' By:      HaHoBe
' Version: 1
' Updated: 20221117
' Reason:  allowing more than one condition for CF
    Dim lngCounter As Long
    Dim rngToWork As Range
    Dim ws As Worksheet
    Dim wsCond As Worksheet
    Dim wsTarg As Worksheet

    On Error GoTo Error_CF
    Set wsCond = Worksheets("CF")
    If wsCond Is Nothing Then GoTo end_here
    'On Error GoTo 0

    'Remove old conditional formatting
    '  For Each Ws In ThisWorkbook.Worksheets
    '    If Ws.Name <> wsCond.Name Then
    '      Ws.Cells.FormatConditions.Delete
    '    End If
    '  Next Ws
    ' Clear formatting
    '/// I would recommend to use the tab name here instead of any position
    Worksheets("SF66OEK").Cells.FormatConditions.Delete
    'Worksheets("Passengers").Cells.FormatConditions.Delete
   
    'Set new formatting
    For lngCounter = 2 To wsCond.Range("A" & Rows.Count).End(3).Row
        On Error GoTo Error_CF
        Set wsTarg = Worksheets(wsCond.Cells(lngCounter, 1).Value)
        If wsTarg Is Nothing Then GoTo end_here
        Set rngToWork = wsTarg.Range(wsCond.Cells(lngCounter, 6).Value, wsCond.Cells(lngCounter, 7).Value)
        If rngToWork Is Nothing Then GoTo end_here
        On Error GoTo 0
        With rngToWork
            Range(wsCond.Cells(lngCounter, 6).Value).Select
            'Debug.Print wsCond.Cells(lngCounter, 3).Value
            .FormatConditions.Add xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value
            If wsCond.Cells(lngCounter, 5).Value <> "" Then
                .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Font.ColorIndex = wsCond.Cells(lngCounter, 5).Value
            End If
            If wsCond.Cells(lngCounter, 4).Value <> "" Then
                .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Interior.Color = wsCond.Cells(lngCounter, 4).Value
            End If
            ' Set Bold or Italic
            If wsCond.Cells(lngCounter, 9).Value <> "" Then
                .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Font.Bold = wsCond.Cells(lngCounter, 9).Value
            End If
            If wsCond.Cells(lngCounter, 10).Value <> "" Then
                .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Font.Italic = wsCond.Cells(lngCounter, 10).Value
            End If
            .FormatConditions(wsCond.Cells(lngCounter, 8)).StopIfTrue = wsCond.Cells(lngCounter, 11).Value

        End With
    Next lngCounter

end_here:
    If wsCond Is Nothing Then
        MsgBox "Check the name of the sheet with the parameters.", vbExclamation, "Name of sheet with parameters"
    ElseIf wsTarg Is Nothing Then
        MsgBox "Check the name of the target sheet", vbExclamation, "Could not find sheet"
    ElseIf rngToWork Is Nothing Then
        MsgBox "Could not build a range to work on, please check addresses.", vbExclamation, "Problems building range"
    End If

    Set rngToWork = Nothing
    Set wsTarg = Nothing
    Set wsCond = Nothing
    MsgBox "CF now reset on " & ActiveWorkbook.Name
    Exit Sub
Error_CF:
    MsgBox "Error in CF module " & Err.Description & " - " & Err.Number
    Resume end_here
End Sub

 

[RoryA]

Just FYI, the Formatconditions.Add method actually returns a reference to the new condition, so you should store that in a variable and reuse it instead of repeatedly calling .FormatConditions(wsCond.Cells(lngCounter, 8).Value)

 

[welshgasman]

Just FYI, the Formatconditions.Add method actually returns a reference to the new condition, so you should store that in a variable and reuse it instead of repeatedly calling .FormatConditions(wsCond.Cells(lngCounter, 8).Value)

Hi @RoryA,
How would I do that please?
I could just use a count as well couldn't I, after you have pointed that out, as I discovered that it does not like missing a sequence?

 

[RoryA]

Like this:

        Dim fc as object
        With rngToWork
            Range(wsCond.Cells(lngCounter, 6).Value).Select
            'Debug.Print wsCond.Cells(lngCounter, 3).Value
            set fc = .FormatConditions.Add(xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value)
            If wsCond.Cells(lngCounter, 5).Value <> "" Then
                fc.Font.ColorIndex = wsCond.Cells(lngCounter, 5).Value
            End If
            If wsCond.Cells(lngCounter, 4).Value <> "" Then
                fc.Interior.Color = wsCond.Cells(lngCounter, 4).Value
            End If
            ' Set Bold or Italic
            If wsCond.Cells(lngCounter, 9).Value <> "" Then
                fc.Font.Bold = wsCond.Cells(lngCounter, 9).Value
            End If
            If wsCond.Cells(lngCounter, 10).Value <> "" Then
                fc.Font.Italic = wsCond.Cells(lngCounter, 10).Value
            End If
            fc.StopIfTrue = wsCond.Cells(lngCounter, 11).Value

        End With

 

[welshgasman]

Like this:

        Dim fc as object
        With rngToWork
            Range(wsCond.Cells(lngCounter, 6).Value).Select
            'Debug.Print wsCond.Cells(lngCounter, 3).Value
            set fc = .FormatConditions.Add(xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value)
            If wsCond.Cells(lngCounter, 5).Value <> "" Then
                fc.Font.ColorIndex = wsCond.Cells(lngCounter, 5).Value
            End If
            If wsCond.Cells(lngCounter, 4).Value <> "" Then
                fc.Interior.Color = wsCond.Cells(lngCounter, 4).Value
            End If
            ' Set Bold or Italic
            If wsCond.Cells(lngCounter, 9).Value <> "" Then
                fc.Font.Bold = wsCond.Cells(lngCounter, 9).Value
            End If
            If wsCond.Cells(lngCounter, 10).Value <> "" Then
                fc.Font.Italic = wsCond.Cells(lngCounter, 10).Value
            End If
            fc.StopIfTrue = wsCond.Cells(lngCounter, 11).Value

        End With

OK, thank you. I will implement that as well.