List all combinations which increase average

Suppose you have a row with 9 numbers. The average is always calculated as an integer (rounded down).
Can you list all possible combinations of minimal value increases to reach the next higher average, if you are only allowed to increase numbers up to the current average?
Example:
The sum of input row numbers (row 2) is 42. You need a sum of 45 to get to the next higher average of 5. Since you can only increase numbers up to the current average of 4, you can only change input cells E2 and I2. There are three possible combinations which are listed in rows 10:12. This problem has been stated in a German Excel forum.
Please read my Disclaimer.
1
Sub Combinations()
2
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/combinatorial-fun/list-all-combinations-which-increase-average V0.1 29-Jun-2020
3
Dim i As Long, j As Long
4
Dim lCount As Long, lSumTarget As Long, lAvg As Long
5
Dim dAvg As Double
6
Dim v As Variant, vMax As Variant, vMin As Variant
7
​
8
With Application.WorksheetFunction
9
​
10
j = 10
11
v = Range(Cells(2, 1), Cells(2, 1).End(xlToRight))
12
lCount = UBound(v, 2) - LBound(v, 2) + 1
13
dAvg = .Average(v)
14
lAvg = .RoundDown(dAvg, 0)
15
lSumTarget = .RoundDown(dAvg + 1#, 0) * lCount
16
​
17
vMax = v
18
For i = 1 To lCount
19
    If vMax(1, i) < lAvg Then vMax(1, i) = lAvg
20
Next i
21
​
22
vMin = v
23
Range("10:65536").Delete
24
Select Case .Sum(vMax)
25
Case Is < lSumTarget
26
    [A10] = "There is no solution."
27
Case Is = lSumTarget
28
    Range(Cells(j, 1), Cells(j, lCount)).FormulaArray = vMax
29
Case Else
30
    i = 1
31
    Do While i <= lCount
32
        Do While v(1, i) = vMax(1, i)
33
            i = i + 1
34
            If i > lCount Then Exit Sub
35
        Loop
36
        v(1, i) = v(1, i) + 1
37
        Do While i > 1
38
            i = i - 1
39
            v(1, i) = vMin(1, i)
40
        Loop
41
        If .Sum(v) = lSumTarget Then
42
            Range(Cells(j, 1), Cells(j, lCount)).FormulaArray = v
43
            j = j + 1
44
        End If
45
    Loop
46
End Select
47
​
48
End With
49
​
50
End Sub
Copied!
Combinations_to_increase_average.xlsm
18KB
Binary

Combinatorial Fun

ConvertTime

Last modified 1yr ago

Copy link