Conditional formatting of cells for 45 different cases with 5 criteria each

[otergutt]

I've made a VBA routine to apply conditional color formatting to cells containing analysis results for various pollutants based on pollution classes. This is no problem for only a couple of pollutants, but when I need to do the same thing for 45 different pollutants, the code will bloat to unmanageable proportions. To make matters a little difficult, the file has a header which puts the column headers in row 7.


Below is the working code for 2 out of 45 elements.

'As (This is the pollutant element)
'Finds the header with the correct name and defines the range as extending from this heading and down to the first empty cell
    Set rngHeaderAs = Range("A1:ZZ200").Find("As*Arsen", lookat:=xlPart) 'Finds column header
    Set rngAs = Range(rngHeaderAs, rngHeaderAs.End(xlDown)) 'Sets the range for the element to be formatted with rules
    AsAddress = rngHeaderAs.Address(False, False) 'Gets the starting cell address for the range, to be used in the formula
    
    'Sets the limit values for the elements
    Dim Ul1As As Double
    Ul1As = 8
    Dim Ul2As As Double
    Ul2As = 20
    Dim Ul3As As Double
    Ul3As = 50
    Dim Ul4As As Double
    Ul4As = 600
    Dim Ul5As As Double
    Ul5As = 1000
    
    'Applies the formatting
    With ActiveSheet


        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & AsAddress & ");" & AsAddress & "<" & Ul1As & ")"
            .FormatConditions(1).Interior.ColorIndex = 33
            .FormatConditions(1).Borders.LineStyle = xlContinuous
            .FormatConditions(1).Borders.Weight = xlThin
            '.FormatConditions(1).Font.Bold = True
            '.FormatConditions(1).Font.ColorIndex = 6


        End With
        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & AsAddress & ");" & AsAddress & ">=" & Ul1As & ";" & AsAddress & "<" & Ul2As & ")"
            .FormatConditions(2).Interior.ColorIndex = 4
            .FormatConditions(2).Borders.LineStyle = xlContinuous
            .FormatConditions(2).Borders.Weight = xlThin
        End With
        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & AsAddress & ");" & AsAddress & ">=" & Ul2As & ";" & AsAddress & "<" & Ul3As & ")"
            .FormatConditions(3).Interior.ColorIndex = 6
            .FormatConditions(3).Borders.LineStyle = xlContinuous
            .FormatConditions(3).Borders.Weight = xlThin
        End With
        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & AsAddress & ");" & AsAddress & ">=" & Ul3As & ";" & AsAddress & "<" & Ul4As & ")"
            .FormatConditions(4).Interior.ColorIndex = 45
            .FormatConditions(4).Borders.LineStyle = xlContinuous
            .FormatConditions(4).Borders.Weight = xlThin


        End With
        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & AsAddress & ");" & AsAddress & ">=" & Ul4As & ";" & AsAddress & "<" & Ul5As & ")"
            .FormatConditions(5).Borders.LineStyle = xlContinuous
            .FormatConditions(5).Borders.Weight = xlThin
            .FormatConditions(5).Interior.ColorIndex = 3
        End With
        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & AsAddress & ");" & AsAddress & ">=" & Ul5As & ")"
            .FormatConditions(6).Interior.ColorIndex = 7
            .FormatConditions(6).Borders.LineStyle = xlContinuous
            .FormatConditions(6).Borders.Weight = xlThin
        End With
        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=LEFT(" & AsAddress & ";1)=""<"""
            .FormatConditions(7).Interior.ColorIndex = 33
            .FormatConditions(7).Borders.LineStyle = xlContinuous
            .FormatConditions(7).Borders.Weight = xlThin
        End With
        With rngAs
            .FormatConditions.Add xlExpression, Formula1:="=(" & AsAddress & ") = ""n.d."""
            .FormatConditions(8).Interior.ColorIndex = 33
            .FormatConditions(8).Borders.LineStyle = xlContinuous
            .FormatConditions(8).Borders.Weight = xlThin
        End With
    End With


'Cd
    Set rngHeaderCd = Range("A1:ZZ200").Find("Cd*Kadmium", lookat:=xlPart)
    Set rngCd = Range(rngHeaderCd, rngHeaderCd.End(xlDown))
    CdAddress = rngHeaderCd.Address(False, False)
        
    Dim Ul1Cd As Double
    Ul1Cd = 1.5
    Dim Ul2Cd As Double
    Ul2Cd = 10
    Dim Ul3Cd As Double
    Ul3Cd = 15
    Dim Ul4Cd As Double
    Ul4Cd = 30
    Dim Ul5Cd As Double
    Ul5Cd = 1000
    
    With ActiveSheet


        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & CdAddress & ");" & CdAddress & "<" & Ul1Cd & ")"
            .FormatConditions(1).Interior.ColorIndex = 33
            .FormatConditions(1).Borders.LineStyle = xlContinuous
            .FormatConditions(1).Borders.Weight = xlThin
        End With
        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & CdAddress & ");" & CdAddress & ">=" & Ul1Cd & ";" & CdAddress & "<" & Ul2Cd & ")"
            .FormatConditions(2).Interior.ColorIndex = 4
            .FormatConditions(2).Borders.LineStyle = xlContinuous
            .FormatConditions(2).Borders.Weight = xlThin
        End With
        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & CdAddress & ");" & CdAddress & ">=" & Ul2Cd & ";" & CdAddress & "<" & Ul3Cd & ")"
            .FormatConditions(3).Interior.ColorIndex = 6
            .FormatConditions(3).Borders.LineStyle = xlContinuous
            .FormatConditions(3).Borders.Weight = xlThin
        End With
        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & CdAddress & ");" & CdAddress & ">=" & Ul3Cd & ";" & CdAddress & "<" & Ul4Cd & ")"
            .FormatConditions(4).Interior.ColorIndex = 45
            .FormatConditions(4).Borders.LineStyle = xlContinuous
            .FormatConditions(4).Borders.Weight = xlThin
        End With
        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & CdAddress & ");" & CdAddress & ">=" & Ul4Cd & ";" & CdAddress & "<" & Ul5Cd & ")"
            .FormatConditions(5).Interior.ColorIndex = 3
            .FormatConditions(5).Borders.LineStyle = xlContinuous
            .FormatConditions(5).Borders.Weight = xlThin
        End With
        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & CdAddress & ");" & CdAddress & ">=" & Ul5Cd & ")"
            .FormatConditions(6).Interior.ColorIndex = 7
            .FormatConditions(6).Borders.LineStyle = xlContinuous
            .FormatConditions(6).Borders.Weight = xlThin
        End With
        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=LEFT(" & CdAddress & ";1)=""<"""
            .FormatConditions(7).Interior.ColorIndex = 33
            .FormatConditions(7).Borders.LineStyle = xlContinuous
            .FormatConditions(7).Borders.Weight = xlThin
        End With
        With rngCd
            .FormatConditions.Add xlExpression, Formula1:="=(" & CdAddress & ") = ""n.d."""
            .FormatConditions(8).Interior.ColorIndex = 33
            .FormatConditions(8).Borders.LineStyle = xlContinuous
            .FormatConditions(8).Borders.Weight = xlThin
        End With
    End With
'and so on for upwards of 45 different pollutants
End Sub

I suspect that an array/select case approach would be much more apppropriate, but I don't know how to work that into my range selection method. I'm attaching a sample analysis file so you can see how it is supposed to work.



Hope anyone can help me.

N1500972.csv

Edit: I replaced referenced values in the limits with fixed ones

[mdmackillop]

For information, I had to replace semi-colons in your code with commas to get it to compile.

[offthelip]

I don't have time to write the code but there seems to be a very easy way:
define U11As,U12As,U13As etc as arrays


You will need to load the constants into each of these arrays, personnaly I would do this by loading the values from a spreadsheet.


then you can loop through you first set of code for 45 times just by changing your variable to indexed variables, obviously you need to Find text as an array as well.


As an example of a few lines


[vba]
' initialise arrays
for i = 1 to 45




Set rngHeaderCd = Range("A1:ZZ200").Find(FINDTEXT(i), lookat:=xlPart)


.FormatConditions.Add xlExpression, Formula1:="=AND(ISNUMBER(" & CdAddress & ");" & CdAddress & "<" & Ul1Cd(i) & ")"
' etc'etc


next i
[/vba]

[otergutt]

Thanks for the suggestion. However, I'm a complete newbie when it comes to arrays, so I can't get my head around how to define the arrays. I have the table of elements and values stored in a spreadsheet which is imported as a separate sheet to the workbook; I'm attaching it here. Could you give me an example on how I would define and populate the arrays?

Thanks again.

Limits.xlsx

[mdmackillop]

Can you post you first csv as an excel file and show in a sample how the data should appear. Rows 7 & 8 need to be split into columns but what is the significance of ;<0? Can these be deleteted to simplify formatting? Column C-E show some cells with "double" entries. How is this to be handled?

[otergutt]

Please find attached the report file saved as Excel in to versions: One version before (N1500972.xlsx) macro is run and one version after (N1500972_colored.xlsx) the macro is run), with the limit values in a separate worksheet (Grenseverdier_jord). The macro pulls the variables from this sheet. Also find attached the complete macro which colors the cells (Color_labreport.docx). The reason for the semicolons is that in Norway, we use comma as decimal separator, and therefore we use semicolons as delimiters in Excel formulas. I have replaced semicolons with commas.

N1500972.xlsxN1500972_colored.xlsx

Color_labreport.docx

I hope this helps you help me

[mdmackillop]

For your consideration

Grenseverdier_jord contains colour for each element/class. Colums are reordered to suit the Match function in the code. Change cells to your requirements; the button will save the colour to the array shown.

Edit sheet contains a copy of your data, stripped of "<" etc. to convert cells to numbers. These are compared to the G-j sheet and coloured accordingly (Note; numbers have been changed here for AS illustration purposes so appear wrong when copied to main sheet)

Colour formatting is copied from Edit to the main sheet.

[otergutt]

Thanks so much. I will change limits and colors to my requirements, but this makes it much easier. Just one thing: How do you define the colors? I don't recognise the numbers as color identifiers.

[otergutt]

Never mind, I just understood it ...