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 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):
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:
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
