Sulprobil
Search…
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:
1
Private Enum xlCI 'Excel Color Index
2
: xlCINone = 0: xlCIBlack: xlCIWhite: xlCIRed: xlCIBrightGreen: xlCIBlue '1 - 5
3
: xlCIYellow: xlCIPink: xlCITurquoise: xlCIDarkRed: xlCIGreen '6 - 10
4
: xlCIDarkBlue: xlCIDarkYellow: xlCIViolet: xlCITeal: xlCIGray25 '11 - 15
5
: xlCIGray50: xlCIPeriwinkle: xlCIPlum: xlCIIvory: xlCILightTurquoise '16 - 20
6
: xlCIDarkPurple: xlCICoral: xlCIOceanBlue: xlCIIceBlue: xlCILightBrown '21 - 25
7
: xlCIMagenta2: xlCIYellow2: xlCICyan2: xlCIDarkPink: xlCIDarkBrown '26 - 30
8
: xlCIDarkTurquoise: xlCISeaBlue: xlCISkyBlue: xlCILightTurquoise2: xlCILightGreen '31 - 35
9
: xlCILightYellow: xlCIPaleBlue: xlCIRose: xlCILavender: xlCITan '36 - 40
10
: xlCILightBlue: xlCIAqua: xlCILime: xlCIGold: xlCILightOrange '41 - 45
11
: xlCIOrange: xlCIBlueGray: xlCIGray40: xlCIDarkTeal: xlCISeaGreen '46 - 50
12
: xlCIDarkGreen: xlCIGreenBrown: xlCIBrown: xlCIDarkPink2: xlCIIndigo '51 - 55
13
: xlCIGray80 '56
14
End Enum
15
​
16
Sub sbHighlightMinAdjacentCellsWhichSumUpToP(r As Range, dPercentage As Double, _
17
Optional rSum As Range, Optional lColorIndexBase As Long = 0, _
18
Optional lColorIndexHighLight As Long = xlCIGray25)
19
'Highlights in lColorIndexHighLight the minimum number of adjacent cells of r
20
'which sum up to dPercentage of the overall total. If rSum is given, the observed
21
'achieved sum is returned in here.
22
'If more than one range certifies then the max is taken.
23
'If more than one range still has same max the top- or leftmost is taken.
24
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbHighlightMinAdjacentCellsWhichSumUpToP
25
'(C) (P) Bernd Plumhoff V0.1 07-Sep-2020
26
Dim d As Double, dNew As Double, dMax As Double
27
Dim lMax As Long, i As Long, j As Long, k As Long
28
Dim v As Variant
29
​
30
With Application.WorksheetFunction
31
For Each v In r
32
r.Interior.ColorIndex = lColorIndexBase
33
Next v
34
d = .Sum(r) * dPercentage
35
For i = 1 To r.Count
36
dMax = 0#
37
For j = 1 To r.Count - i + 1
38
dNew = 0#
39
For k = j To j + i - 1
40
dNew = dNew + r(k)
41
Next k
42
If dNew >= d Then
43
If dNew > dMax Then
44
dMax = dNew
45
lMax = j
46
End If
47
End If
48
Next j
49
If dMax > 0# Then Exit For
50
Next i
51
For j = lMax To lMax + i - 1
52
r(j).Interior.ColorIndex = lColorIndexHighLight
53
Next j
54
If Not rSum Is Nothing Then rSum = dMax
55
End With
56
End Sub
57
​
58
Sub doit()
59
Call sbHighlightMinAdjacentCellsWhichSumUpToP([C3:Q3], 0.5, [T3])
60
Call sbHighlightMinAdjacentCellsWhichSumUpToP([B12:B26], 0.5, [B29], _
61
xlCIBrightGreen, xlCIGreen) 'Test whether this works vertically as well
62
End Sub
Copied!
sbHighlightMinAdjacentCellsWhichSumUpToP.xlsm
27KB
Binary
Last modified 1yr ago
Copy link