sbHighlightMinAdjacentCellsWhichSumUpToP
Do you need to highlight the minimum number of adjacent cells which sum up to a certain percentage of the total of a range?
Here you are:
Private Enum xlCI 'Excel Color Index
: xlCINone = 0: xlCIBlack: xlCIWhite: xlCIRed: xlCIBrightGreen: xlCIBlue '1 - 5
: xlCIYellow: xlCIPink: xlCITurquoise: xlCIDarkRed: xlCIGreen '6 - 10
: xlCIDarkBlue: xlCIDarkYellow: xlCIViolet: xlCITeal: xlCIGray25 '11 - 15
: xlCIGray50: xlCIPeriwinkle: xlCIPlum: xlCIIvory: xlCILightTurquoise '16 - 20
: xlCIDarkPurple: xlCICoral: xlCIOceanBlue: xlCIIceBlue: xlCILightBrown '21 - 25
: xlCIMagenta2: xlCIYellow2: xlCICyan2: xlCIDarkPink: xlCIDarkBrown '26 - 30
: xlCIDarkTurquoise: xlCISeaBlue: xlCISkyBlue: xlCILightTurquoise2: xlCILightGreen '31 - 35
: xlCILightYellow: xlCIPaleBlue: xlCIRose: xlCILavender: xlCITan '36 - 40
: xlCILightBlue: xlCIAqua: xlCILime: xlCIGold: xlCILightOrange '41 - 45
: xlCIOrange: xlCIBlueGray: xlCIGray40: xlCIDarkTeal: xlCISeaGreen '46 - 50
: xlCIDarkGreen: xlCIGreenBrown: xlCIBrown: xlCIDarkPink2: xlCIIndigo '51 - 55
: xlCIGray80 '56
End Enum
Sub sbHighlightMinAdjacentCellsWhichSumUpToP(r As Range, dPercentage As Double, _
Optional rSum As Range, Optional lColorIndexBase As Long = 0, _
Optional lColorIndexHighLight As Long = xlCIGray25)
'Highlights in lColorIndexHighLight the minimum number of adjacent cells of r
'which sum up to dPercentage of the overall total. If rSum is given, the observed
'achieved sum is returned in here.
'If more than one range certifies then the max is taken.
'If more than one range still has same max the top- or leftmost is taken.
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbHighlightMinAdjacentCellsWhichSumUpToP
'(C) (P) Bernd Plumhoff V0.1 07-Sep-2020
Dim d As Double, dNew As Double, dMax As Double
Dim lMax As Long, i As Long, j As Long, k As Long
Dim v As Variant
With Application.WorksheetFunction
For Each v In r
r.Interior.ColorIndex = lColorIndexBase
Next v
d = .Sum(r) * dPercentage
For i = 1 To r.Count
dMax = 0#
For j = 1 To r.Count - i + 1
dNew = 0#
For k = j To j + i - 1
dNew = dNew + r(k)
Next k
If dNew >= d Then
If dNew > dMax Then
dMax = dNew
lMax = j
End If
End If
Next j
If dMax > 0# Then Exit For
Next i
For j = lMax To lMax + i - 1
r(j).Interior.ColorIndex = lColorIndexHighLight
Next j
If Not rSum Is Nothing Then rSum = dMax
End With
End Sub
Sub doit()
Call sbHighlightMinAdjacentCellsWhichSumUpToP([C3:Q3], 0.5, [T3])
Call sbHighlightMinAdjacentCellsWhichSumUpToP([B12:B26], 0.5, [B29], _
xlCIBrightGreen, xlCIGreen) 'Test whether this works vertically as well
End Sub
sbHighlightMinAdjacentCellsWhichSumUpToP.xlsm
27KB
Binary
Last modified 2yr ago