VBA apply conditional formatting

K

Kra

Board Regular
Joined
Jul 4, 2022
Messages
160
Office Version
  1. 365
Platform
  1. Windows
Hi all!

I am trying to create variable conditional formatting. User will determine range and rules in sheet called CondFormat. This is how it looks like, is it possible to apply it with VBA? I tried to create macro, but I cannot create a way to get values from cells (like in which sheet is should be applied). Colors are used in hex format, so I added "&H" to cells with color (column 4 and 5). Any ideas how to fix it / achieve it?

1667317653872.png



VBA Code: 
Sub CondForm()
Dim rngStart As Range
Dim rngStop As Range
Dim Cond1 As FormatCondition
Dim Cond2 As FormatCondition
Dim Ws As Worksheet


Dim LastRow As Integer
    LastRow = Worksheets("CondFormat").Range("A" & Rows.Count).End(3).Row
    
'Remove old conditional formatting
For Each Ws In ThisWorkbook.Sheets

    Ws.Cells.FormatConditions.Delete
    
Next


'Set new formatting
Dim x As Integer
    For x = 2 To LastRow

'HOW TO SET THIS WORKSHEET FROM CELL VALUE?
        Ws = Worksheets(Cells(x, 1).Value)
        rngStart = Cells(x, 6).Value
        rngStop = Cells(x, 7).Value
        
    Ws.Range(rngStart, rngStop).FormatConditions.Add xlExpression, Formula1:= _
            Cells(x, 3).Value
    Ws.Range(rngStart, rngStop).FormatConditions.Interior.Color = Cells(x, 4).Value
    Ws.Range(rngStart, rngStop).FormatConditions.Font.Color = Cells(x, 5).Value
    
    Next x


End Sub
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Sort by date Sort by votes
Hi Kra,

my sheet looks like this:

MrE_1613209 1220882 _221102_085636.xlsm
ABCDEFG
1
2BusDepFormula:==$A1>=96528016777215B1B1
3
CondFormat


I altered the Hexadecimals to longs (vbGreen and vbWhite in the sample), altered some of the information you placed and especially the ranges to use this code:

VBA Code: 
Sub MrE1220882_1613209()
  Dim Ws              As Worksheet
  Dim lngCounter      As Long
  Dim wsCond          As Worksheet
  Dim wsTarg          As Worksheet
  Dim rngToWork       As Range
 
  On Error Resume Next
  Set wsCond = Worksheets("CondFormat")
  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
 
  'Set new formatting
  For lngCounter = 2 To wsCond.Range("A" & Rows.Count).End(3).Row
    On Error Resume Next
    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
      .FormatConditions.Add xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value
      .FormatConditions(1).Font.Color = wsCond.Cells(lngCounter, 5).Value
      .FormatConditions(1).Interior.Color = wsCond.Cells(lngCounter, 4).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

End Sub

Ciao,
Holger
 
Upvote 0
Solution
HaHoBe said:
Hi Kra,

my sheet looks like this:

MrE_1613209 1220882 _221102_085636.xlsm
ABCDEFG
1
2BusDepFormula:==$A1>=96528016777215B1B1
3
CondFormat


I altered the Hexadecimals to longs (vbGreen and vbWhite in the sample), altered some of the information you placed and especially the ranges to use this code:

VBA Code: 
Sub MrE1220882_1613209()
  Dim Ws              As Worksheet
  Dim lngCounter      As Long
  Dim wsCond          As Worksheet
  Dim wsTarg          As Worksheet
  Dim rngToWork       As Range
 
  On Error Resume Next
  Set wsCond = Worksheets("CondFormat")
  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
 
  'Set new formatting
  For lngCounter = 2 To wsCond.Range("A" & Rows.Count).End(3).Row
    On Error Resume Next
    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
      .FormatConditions.Add xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value
      .FormatConditions(1).Font.Color = wsCond.Cells(lngCounter, 5).Value
      .FormatConditions(1).Interior.Color = wsCond.Cells(lngCounter, 4).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

End Sub

Ciao,
Holger
Click to expand...
Thank you Holger! Works fine!
 
Upvote 0
Hi,
May I jump in on this thread please.
I was looking for a way to set CF in VBA, and came upon this thread on a search.

This seems a more flexible way to apply CF, if I can get it to work. :( I also only need it on one sheet at present.

I copied the code, and amended a sheet for the values.

This is my CF sheet
1668691730916.png


I am trying to set as per manually
1668691777932.png


However it only ever sets for the first rule?

1668692233049.png


What am I missing please?

Alternatively if I can set them in simple VBA, I would be happy with that, but I could not get the double quotes correct in VBA. :(

My code
Code: 
Sub Add_CF()
  Dim Ws              As Worksheet
  Dim lngCounter      As Long
  Dim wsCond          As Worksheet
  Dim wsTarg          As Worksheet
  Dim rngToWork       As Range
 
  On Error Resume Next
  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
    Sheets(1).Activate
    ActiveSheet.Cells.FormatConditions.Delete
  'Set new formatting
  For lngCounter = 2 To wsCond.Range("A" & Rows.Count).End(3).Row
    On Error Resume Next
    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
      .FormatConditions.Add xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value
      .FormatConditions(1).Font.Color = wsCond.Cells(lngCounter, 5).Value
      .FormatConditions(1).Interior.Color = wsCond.Cells(lngCounter, 4).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

End Sub
TIA
 
Upvote 0
No need for a reply.
Finally worked it out. Had to increment the FormatCondition index, so I used lngCounter -1

Thank you for the code.
 
Upvote 0
OK, that was a little premature. :(

The code is not setting the values as you would manually, but surround them with double quotes, so noting takes effect.?

How can I get the values as you would enter manually please?
 
Upvote 0
Hi welshgasman,

table looks like this, to display the formulas they look like '=$O4>=0

MrE_1220882_1614111_vba apply conditiona_221117.xlsm
ABCDEFGH
1SheetRule TypeRule DescriptionFill ColorFont ColorFromToNumber
2SF66OEKFormula:==$O4>=065280A4A41
3SF66OEKFormula:==$K4="Yes"65280A4A42
4SF66OEKFormula:==$E4="Cancelled"255A4A43
5SF66OEKFormula:==$H4=$I416711935A4A44
CF


Result looks like this:
MrE_1220882_1614111_vba apply conditiona_221117.xlsm
ABCDEFGHIJKLMNO
4asdfCancelled1No-1
SF66OEK
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A4Expression=$O4>=0textYES
A4Expression=$K4= "Yes"textYES
A4Expression=$E4="Cancelled"textYES
A4Expression=$H4=$I4textYES


VBA Code: 
Sub MrE_1220882_1614111_Add_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 Resume Next
  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(1).Cells.FormatConditions.Delete
'Set new formatting
  For lngCounter = 2 To wsCond.Range("A" & Rows.Count).End(3).Row
    On Error Resume Next
    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
      .FormatConditions.Add xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value
      .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Font.Color = wsCond.Cells(lngCounter, 5).Value
      .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Interior.Color = wsCond.Cells(lngCounter, 4).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

End Sub

Ciao,
Holger
 
Upvote 0
Hi Holger,

Thank you, that works a treat. (y)

I added
Code: 
            .FormatConditions(wsCond.Cells(lngCounter, 8)).StopIfTrue = False
as it defaults to true.

Spend the best part of the day on this, tryingother peoples code, which would nt work for me for some reason. :(
So very grateful for your solution.
 
Upvote 0
OK, had to come back to this. :(
AFAIK I have not changed anything code wise, other than add an extra row for for anoher sheet, but when I run the code, instead of putting the formula that is in column C, it is substistuting the address row for 1048359 or some other huge number like 1048575.
For the life of me I cannot find out why. :(

I have walked through the code, added an error section just in case and cannot find out why. No error reported.

Would you have any ideas please?

The pic is for the last row of the CF sheet. The same number appears for SF666OEK
1686384338803.png


Code: 
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
            .FormatConditions.Add xlExpression, Formula1:=wsCond.Cells(lngCounter, 3).Value
            .FormatConditions(wsCond.Cells(lngCounter, 8).Value).Font.Color = 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
1686384487850.png

1686384601612.png
 

Attachments

  • 1686384309242.png
    1686384309242.png
    24.7 KB · Views: 18
Last edited:
Upvote 0
Actual row number appears to be random. Run subsequently and last one is 1048550.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Conditional formatting Coloring due dates
Replies
4
Views
206
JAZ91
J
J
  • Question Question
Multiple conditional formatting
Replies
6
Views
308
StephenCrump
S
H
  • Solved
VBA Code to Enter Formula in the Cell as Array Formula
Replies
5
Views
79
MARK858
MARK858
J
  • Question Question
VBA Search box and button code
Replies
0
Views
272
jlcodes
J
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
123
vanessavalentino83
V

Forum statistics

Threads
1,224,823
Messages
6,181,175
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top