Sub MrE161360A()
'https://www.mrexcel.com/board/threads/macro-to-select-cells-between-total-rows-for-gradient-fill.1221249/
Dim lngCounter As Long 'looping through the cells
Dim lngEnd As Long 'row to start with
Dim lngStart As Long 'row to end with
Dim lngFG As Long 'looping through array
Dim varArr As Variant 'array holding the offset for columns to work on
Dim strAddress As String 'holding the rather long code to determine where to work
Const cstrVALUE As String = "Total" 'searching for the exact match
Const cstrCSEARCH As String = "B" 'Column letter for search
varArr = Array(4, 5, 7)
With ActiveSheet
For lngCounter = .Cells(.Rows.Count, cstrCSEARCH).End(xlUp).Row To 2 Step -1
If .Cells(lngCounter, cstrCSEARCH).Value = cstrVALUE Then
lngEnd = lngCounter - 1
lngStart = WorksheetFunction.Max(.Cells(lngCounter, cstrCSEARCH).End(xlUp).Row, 2)
For lngFG = LBound(varArr) To UBound(varArr)
strAddress = .Range(.Cells(lngStart, cstrCSEARCH), .Cells(lngEnd, cstrCSEARCH)).Offset(, varArr(lngFG)).Address(0, 0)
If Not FillGradient(strAddress) Then
MsgBox "Problem occurred filling gradient to range: " & strAddress, vbInformation, "Error here"
End If
Next lngFG
lngCounter = lngStart + 1
End If
Next lngCounter
End With
End Sub
Function FillGradient(strRange As String) As Boolean
FillGradient = False
On Error GoTo end_here
With Range(strRange)
.FormatConditions.Delete
.FormatConditions.AddColorScale ColorScaleType:=3
.FormatConditions(.FormatConditions.Count).SetFirstPriority
End With
With Range(strRange).FormatConditions(1)
With .ColorScaleCriteria(1)
.Type = xlConditionValueLowestValue
With .FormatColor
.Color = 7039480
.TintAndShade = 0
End With
End With
With .ColorScaleCriteria(2)
.Type = xlConditionValuePercentile
.Value = 50
With .FormatColor
.Color = 8711167
.TintAndShade = 0
End With
End With
With .ColorScaleCriteria(3)
.Type = xlConditionValueHighestValue
With .FormatColor
.Color = 8109667
.TintAndShade = 0
End With
End With
End With
FillGradient = True
Exit Function
end_here:
End Function
