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:

Please read my Disclaimer.

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
PrevioussbGSortNextsbInterp

Last updated