Cell Gradient Fill Macro

Question

I have two functions here, each one displays the gradient slightly differently with up to 5 gradients.

Function 1:

Function addCellColor(ByVal c As Range, ByVal color As Long)
 Dim c1 As Long, c2 As Long, c3 As Long, c4 As Long
 'creates a gradient pattern if one doesn't already exist
 With c.Interior
 If .color = 16777215 Then
 .Pattern = xlPatternLinearGradient
 .gradient.Degree = 0
 .gradient.ColorStops.Clear
 End If
 End With
 ' adds gradient color to cell up to 5 colors
 If Not c.Interior.gradient Is Nothing Then
 With c.Interior.gradient
 ' if the cell is already colored
 If .ColorStops.count <> 0 Then
 Select Case .ColorStops.count
 Case 2
 If .ColorStops(1).color = .ColorStops(2).color Then
 c1 = .ColorStops(1).color
 .ColorStops.Clear
 .ColorStops.Add(0).color = c1
 .ColorStops.Add(0.45).color = c1
 .ColorStops.Add(0.55).color = color
 .ColorStops.Add(1).color = color
 End If
 Case 4
 If .ColorStops(1).color <> color And .ColorStops(2).color <> color And .ColorStops(3).color <> color And .ColorStops(4).color <> color Then
 c1 = .ColorStops(1).color: c2 = .ColorStops(3).color
 .ColorStops.Clear
 .ColorStops.Add(0).color = c1
 .ColorStops.Add(0.28).color = c1
 .ColorStops.Add(0.38).color = c2
 .ColorStops.Add(0.61).color = c2
 .ColorStops.Add(0.71).color = color
 .ColorStops.Add(1).color = color
 End If
 Case 6
 If .ColorStops(1).color <> color And .ColorStops(2).color <> color And .ColorStops(3).color <> color _
 And .ColorStops(4).color <> color And .ColorStops(5).color <> color And .ColorStops(6).color <> color Then
 c1 = .ColorStops(1).color: c2 = .ColorStops(3).color: c3 = .ColorStops(5).color
 .ColorStops.Clear
 .ColorStops.Add(0).color = c1
 .ColorStops.Add(0.2).color = c1
 .ColorStops.Add(0.3).color = c2
 .ColorStops.Add(0.45).color = c2
 .ColorStops.Add(0.55).color = c3
 .ColorStops.Add(0.7).color = c3
 .ColorStops.Add(0.8).color = color
 .ColorStops.Add(1).color = color
 End If
 Case 8
 If .ColorStops(1).color <> color And .ColorStops(2).color <> color And .ColorStops(3).color <> color And .ColorStops(4).color <> color _
 And .ColorStops(5).color <> color And .ColorStops(6).color <> color And .ColorStops(7).color <> color And .ColorStops(8).color <> color Then
 c1 = .ColorStops(1).color: c2 = .ColorStops(3).color: c3 = .ColorStops(5).color: c4 = .ColorStops(7).color
 .ColorStops.Clear
 .ColorStops.Add(0).color = c1
 .ColorStops.Add(0.15).color = c1
 .ColorStops.Add(0.25).color = c2
 .ColorStops.Add(0.35).color = c2
 .ColorStops.Add(0.45).color = c3
 .ColorStops.Add(0.55).color = c3
 .ColorStops.Add(0.65).color = c4
 .ColorStops.Add(0.75).color = c4
 .ColorStops.Add(0.85).color = color
 .ColorStops.Add(1).color = color
 End If
 End Select
 ' if cell has no colors yet
 Else
 .ColorStops.Add(0).color = color
 .ColorStops.Add(1).color = color
 End If
 End With
 End If
End Function

Output (completes in 2 minutes and 10 seconds when ran on a collection of ~4500 items):

Function 1 output

Function 2:

Function addCellColor1(ByVal c As Range, ByVal color As Long)
 Dim c1 As Long, c2 As Long, c3 As Long, c4 As Long
 'creates a gradient pattern if one doesn't already exist
 With c.Interior
 If .color = 16777215 Then
 .Pattern = xlPatternLinearGradient
 .gradient.Degree = 0
 .gradient.ColorStops.Clear
 End If
 End With
 ' adds gradient color to cell up to 5 colors
 If Not c.Interior.gradient Is Nothing Then
 With c.Interior.gradient
 ' if the cell is already colored
 If .ColorStops.count <> 0 Then
 Select Case .ColorStops.count
 Case 2
 If .ColorStops(1).color = .ColorStops(2).color Then
 .ColorStops(2).color = color
 ElseIf .ColorStops(1).color <> color And .ColorStops(2).color <> color Then
 c1 = .ColorStops(1).color: c2 = .ColorStops(2).color
 .ColorStops.Clear
 .ColorStops.Add(0).color = c1
 .ColorStops.Add(0.5).color = c2
 .ColorStops.Add(1).color = color
 End If
 Case 3
 If .ColorStops(1).color <> color And .ColorStops(2).color <> color And .ColorStops(3).color <> color Then
 c1 = .ColorStops(1).color: c2 = .ColorStops(2).color: c3 = .ColorStops(3).color
 .ColorStops.Clear
 .ColorStops.Add(0).color = c1
 .ColorStops.Add(0.33).color = c2
 .ColorStops.Add(0.66).color = c3
 .ColorStops.Add(1).color = color
 End If
 Case 4
 If .ColorStops(1).color <> color And .ColorStops(2).color <> color And .ColorStops(3).color <> color And .ColorStops(4).color <> color Then
 c1 = .ColorStops(1).color: c2 = .ColorStops(2).color: c3 = .ColorStops(3).color: c4 = .ColorStops(4).color
 .ColorStops.Clear
 .ColorStops.Add(0).color = c1
 .ColorStops.Add(0.25).color = c2
 .ColorStops.Add(0.5).color = c3
 .ColorStops.Add(0.75).color = c4
 .ColorStops.Add(1).color = color
 End If
 End Select
 ' if cell has no colors yet
 Else
 .ColorStops.Add(0).color = color
 .ColorStops.Add(1).color = color
 End If
 End With
 End If
End Function

Output (completes in 1 minute and 12 seconds when ran on a collection of ~4500 items):

Function 2 output

It is recommended to have the below function run before this one

Function Opt_Start()
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual
 ActiveSheet.DisplayPageBreaks = False
 Application.DisplayAlerts = False
End function

Particularly looking for an optimization review since the functions take a long time to run when it is ran in a loop.

Additional info:

I have collected a large amount of data in a VBA Collection that looks like this:

Collection

The data collection for this (approx 4500 items) takes about 5 seconds, the gradient fill takes minutes.

This is all I am permitted to share: This is how the cell colors are determined.

Private Function FormatDocument()
 Dim p As FormulaParameter
 Dim green As Long, orange As Long, lRed As Long, dRed As Long, magenta As Long, dGrey As Long
 Debug.Print ("Formatting Cells")
 green = RGB(146, 208, 80)
 orange = RGB(255, 192, 0)
 lRed = RGB(255, 80, 80)
 dRed = RGB(192, 0, 0)
 magenta = RGB(252, 117, 255)
 dGrey = RGB(120, 120, 120)
 For Each p In coll
 If Not p Is Nothing Then
 With p
 ' Error 2: Step name not found for the operation parameter
 ' this error will just be logged no format changes
 'Cell is orange if the value in that cell has been modified at all. Overrides others.
 ' if error says "Parameter was tracked successfully." change the formula and unit level defenition if not = "Operation default"
 ' if it is an operation default value, change the unit parameter to its default value
 If .newValue = "Operation Default" Then
 '********************** This block will change UP level parameter ***************************************
 'If Not .uParam Is Nothing Then
 ' .uParam.Offset(0, 1).value = .defValue
 ' Call addCellColor(.uParam.Offset(0, 1), orange)
 ' Call ReplaceUnits(.uParam.Offset(0, 2))
 'End If
 '********************** This block will change UP level parameter ***************************************
 '************ This line will change OP level parameter and delete UP parameter **************************
 If Not .oParam2 Is Nothing Then
 .oParam2.Offset(0, 1).value = .defValue
 Call addCellColor(.oParam2.Offset(0, 1), orange)
 Call ReplaceUnits(.oParam2.Offset(0, 2))
 If Not .uParam Is Nothing Then
 .uParam.Offset(0, 1).value = ""
 .uParam.value = ""
 .uParam.Offset(0, -1).value = "VALUE"
 .uParam.Offset(0, -1).Font.color = vbRed
 End If
 End If
 '************ This line will change OP level parameter and delete UP parameter **************************
 Else
 If Not .fParam Is Nothing And .newValue <> "" Then .fParam.Offset(0, .fOffset).value = .newValue
 If Not .fParam Is Nothing And .newValue <> "" Then Call addCellColor(.fParam.Offset(0, .fOffset), orange)
 End If
 ' Error 10: there was not a unit parameter for the corresponding operation parameter on uTab
 ' This will also have a default value put into the value in UP
 If InStr(1, .error, "Error 10:") > 0 And .newValue = "Operation Default" Then
 ' .uParam.Offset(0, 1).value = .defValue ' this will change if changing at operation level
 ' If Not .uParam Is Nothing Then Call addCellColor(.uParam.Offset(0, 1), orange)
 '************************************************ added for op level change
 If Not .oParam2 Is Nothing Then
 .oParam2.Offset(0, 1).value = .defValue
 Call addCellColor(.oParam2.Offset(0, 1), orange)
 Call ReplaceUnits(.oParam2.Offset(0, 2))
 If Not .oParam1 Is Nothing Then
 .oParam1.Offset(0, 4).value = ""
 .oParam1.Offset(0, 2).value = "VALUE"
 .oParam1.Offset(0, 2).Font.color = vbRed
 End If
 End If
 '************************************************ added for op level change
 End If
 'Cell is green if the value, or parameter in that cell was able to be tracked successfully throughout the two documents.
 ' catches unit level parameters
 ' if error says "Parameter was tracked successfully."
 If .error = "Parameter was tracked successfully." Or .error = "Parameter is a Unit Procedure level defenition" Then
 If Not .uParam Is Nothing Then Call addCellColor(.uParam, green)
 If Not .oParam1 Is Nothing Then Call addCellColor(.oParam1, green)
 If Not .oParam2 Is Nothing Then Call addCellColor(.oParam2, green)
 If Not .rParam Is Nothing Then Call addCellColor(.rParam, green)
 If Not .pParam Is Nothing Then Call addCellColor(.pParam, green)
 If Not .pParam Is Nothing Then Call addCellColor(.pParam.Offset(0, .pOffset), green)
 If Not .pParam Is Nothing Then Call addCellColor(.pParam.Offset(0, .dOffset), green)
 If .error = "Parameter is a Unit Procedure level defenition" And Not .fParam Is Nothing Then Call addCellColor(.fParam.Offset(0, .fOffset), green)
 End If
 'Cell is light red due to a possible mismatch in the R_ parameter from the OP tabs to the PH tabs or vice versa.
 ' Error 1: Parameter in formula was not found in an operation OR
 ' Error 2: Step name not found for the operation parameter OR
 ' Error 3: Operation tab was not found
 ' Error 4: Operation parameter not found in operation tab
 ' Error 6: Recipe parameter not found in phase tab
 ' Error 8: Recipe parameter in the phase was not found in the operation
 ' Error 9: operation parameter from the operation was not found in the Unit procedure
 If InStr(1, .error, "Error 1:") > 0 Or InStr(1, .error, "Error 2:") > 0 Or InStr(1, .error, "Error 4:") > 0 _
 Or InStr(1, .error, "Error 6:") > 0 Or InStr(1, .error, "Error 8:") > 0 Or InStr(1, .error, "Error 9:") > 0 _
 Or InStr(1, .error, "Error 3:") > 0 Then
 If Not .pParam Is Nothing Then Call addCellColor(.pParam, lRed)
 If Not .pParam Is Nothing Then Call addCellColor(.pParam.Offset(0, .dOffset), lRed)
 If Not .pParam Is Nothing Then Call addCellColor(.pParam.Offset(0, .pOffset), lRed)
 If Not .rParam Is Nothing Then Call addCellColor(.rParam, lRed)
 If Not .oParam1 Is Nothing Then Call addCellColor(.oParam1, lRed)
 If Not .oParam2 Is Nothing Then Call addCellColor(.oParam2, lRed)
 If Not .uParam Is Nothing Then Call addCellColor(.uParam, lRed)
 If Not .fParam Is Nothing Then Call addCellColor(.fParam.Offset(0, .fOffset), lRed)
 End If
 'Cell is dark red if the parameter is blank in the parameter value document.
 ' Error 10: there was not a unit parameter for the corresponding operation parameter on uTab
 ' or the parameter is empty in phase tab
 If InStr(1, .error, "Error 10:") > 0 Or (Not .pParam Is Nothing And .newValue = "" And .pOffset <> 0) Then
 If Not .pParam Is Nothing Then Call addCellColor(.pParam, dRed)
 If Not .pParam Is Nothing Then Call addCellColor(.pParam.Offset(0, .dOffset), dRed)
 If Not .pParam Is Nothing Then Call addCellColor(.pParam.Offset(0, .pOffset), dRed)
 If Not .rParam Is Nothing Then Call addCellColor(.rParam, dRed)
 If Not .uParam Is Nothing Then Call addCellColor(.uParam, dRed)
 If Not .oParam1 Is Nothing Then Call addCellColor(.oParam1, dRed)
 If Not .oParam2 Is Nothing Then Call addCellColor(.oParam2, dRed)
 If Not .fParam Is Nothing Then Call addCellColor(.fParam.Offset(0, .fOffset), dRed)
 End If
 'Cell is magenta if there were no parameter values found for this phase on this column/formula.
 ' Error 7: There does not exist parameter value for this phase on this formula
 ' Error 5: Phase tab was not found
 If InStr(1, .error, "Error 5:") > 0 Or InStr(1, .error, "Error 7:") > 0 Then
 If Not .fParam Is Nothing Then Call addCellColor(.fParam.Offset(0, .fOffset), magenta)
 If Not .uParam Is Nothing Then Call addCellColor(.uParam, magenta)
 If Not .oParam1 Is Nothing Then Call addCellColor(.oParam1, magenta)
 If Not .oParam2 Is Nothing Then Call addCellColor(.oParam2, magenta)
 If Not .rParam Is Nothing Then Call addCellColor(.rParam, magenta)
 End If
 'Cell is dark grey if the value, or parameter in that cell is operation default. (Some may be light grey)
 ' para.newValue = operation default
 If .newValue = "Operation Default" Then
 If Not .rParam Is Nothing Then Call addCellColor(.rParam, dGrey)
 If Not .oParam1 Is Nothing Then Call addCellColor(.oParam1, dGrey)
 If Not .oParam2 Is Nothing Then Call addCellColor(.oParam2, dGrey)
 If Not .uParam Is Nothing Then Call addCellColor(.uParam, dGrey)
 If Not .fParam Is Nothing Then Call addCellColor(.fParam.Offset(0, .fOffset), dGrey)
 End If
 'Cell is white if that cell was not able to be checked across documents, or invalid entries exist. Most commonly the cells are white because
 'they did not exist in the formula but they did in the operation, or they did not exist in the parameter document. Cells white in parameter
 'document because they were never looked at due to mismatched names.
 End With
 End If
 Next p
End Function

Linked question on StackOverflow

• Mathieu Guindon: Welcome to CR! I've added the runtimes from the linked SO post (I'd recommend removing the SO question) - curious what the inputs are for such times, surely it doesn't take 1-2 minutes to fill up just one cell? Feel free to edit your post to include the code that uses these functions, too!
• Jerm: @MathieuGuindon - Thanks for the help you are giving me, much appreciated! I've edited the post with some more info but it is all I am allowed to share. There are MANY cells being filled. My main issue is one function takes longer than the other, but do the same thing really.
• Mathieu Guindon: That's perfect! I don't think having the two functions is necessary though - just including the one that's actually being used should be good enough. Side note, you might want to look into what low-hanging fruit Rubberduck's code inspections can find & fix. (note: I and a bunch of reviewers monitoring the VBA tag, contribute to this free/open-source project; star us on GitHub if you like! see the rubberduck tag for more details)
• Jerm: @MathieuGuindon - I know about Rubberduck, but I am not able to run it on this work computer, it unfortunately gets blocked. It would be very useful.
• Tim Williams: Instead of clearing all of the colorstops and re-adding them, you could adjust the position of the existing stops and just add the one new one. That might be faster.

Answer 1

Following my suggestion in the comments, turns out this is only slightly faster: for 5 colors over 5000 cells it's ~6.1 sec vs. ~8.5 sec for your Function 2...

Sub addCellColor2(ByVal c As Range, ByVal color As Long)
 Dim step, pos, i As Long, n As Long, cStop As ColorStop
 With c.Interior
 If .color = 16777215 Then
 .Pattern = xlPatternLinearGradient
 .Gradient.Degree = 0
 With .Gradient.ColorStops
 .Item(1).color = color
 .Item(2).color = color
 End With
 Exit Sub
 End If
 End With
 With c.Interior.Gradient
 'see if this color already exists
 For Each cStop In .ColorStops
 If cStop.color = color Then Exit Sub
 Next cStop
 n = .ColorStops.Count
 If n = 2 And .ColorStops(1).color = .ColorStops(2).color Then
 .ColorStops(2).color = color
 Exit Sub
 End If
 step = Round(1 / (n), 3)
 pos = step
 For i = 2 To n
 .ColorStops(i).Position = pos
 pos = pos + step
 Next i
 .ColorStops.Add(1).color = color
 End With
End Sub

• Jerm: Sped it up a little bit yeah. My boss really wants Function 1 unfortunately and I have not been able to work out the math for just adding these stops easily. I think it will just have to stick to being a time consuming macro. We will only be running it for a few weeks anyways a few times a day, so not too much time is lost.