sbListAssetWeightCombinations
You need to list all possible combinations of asset weights which need to add up to 100%? 1
Sub sbListAssetWeightCombinations_Double()
2
'List all asset weight combinations for a given count of assets and
3
'for a given (double precision) increment (to increase asset weights from 0%
4
'up to 100%.
5
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sblistassetweightcombinations 05.04.2021 v0.2
6
Dim d As Double, dCheckSum As Double, dIncrement As Double, dSum As Double
7
Dim i As Long, j As Long
8
Dim lAssets As Long, lRow As Long
9
10
wsD.Range("A4:A1048576").EntireRow.Delete
11
dSum = 100#
12
dIncrement = Range("dIncrement")
13
lAssets = Range("dAssets")
14
ReDim dA(1 To lAssets) As Double
15
dCheckSum = Application.WorksheetFunction.Combin(Int(dSum / dIncrement) _
16
+ lAssets - 1, lAssets - 1)
17
If Abs(Int(dSum / dIncrement) * dIncrement - dSum) > 0.0000000000001 Then
18
Call MsgBox(dSum & " divided by increment " & dIncrement & _
19
" gives a remainder <> 0!", vbOKOnly, "Error")
20
Exit Sub
21
ElseIf dCheckSum > 1048576# - 4# Then
22
Call MsgBox("I don't have enough rows to list all " & _
23
dCheckSum & " combinations!", vbOKOnly, "Error")
24
Exit Sub
25
ElseIf dCheckSum > 100000# Then
26
If vbCancel = MsgBox("Have you got enough time to wait for " & _
27
dCheckSum & " combinations?", vbOKCancel, "Question") Then
28
Exit Sub
29
End If
30
End If
31
wsD.Cells(4, 1) = "#"
32
For i = 1 To lAssets
33
wsD.Cells(4, 1 + i) = Chr(64 + i)
34
Next i
35
lRow = 5
36
i = 1
37
Do While i <= lAssets
38
dA(i) = dA(i) + dIncrement
39
If dA(i) > dSum Then
40
dA(i) = 0#
41
i = i + 1
42
Else
43
d = dA(1)
44
For j = 2 To lAssets
45
d = d + dA(j)
46
Next j
47
If Abs(d - dSum) < 0.0000000000001 Then
48
wsD.Cells(lRow, 1) = lRow - 4
49
For j = 1 To lAssets
50
wsD.Cells(lRow, j + 1) = dA(j)
51
Next j
52
lRow = lRow + 1
53
End If
54
i = 1
55
End If
56
Loop
57
Range("dCombinationCount").Value = IIf(lRow - 5 = dCheckSum, dCheckSum, _
58
"Error: I expected " & dCheckSum & " combinations but I counted " & _
59
lRow - 5)
60
End Sub
61
62
Sub sbListAssetWeightCombinations_Integer()
63
'List all asset weight combinations for a given count of assets and
64
'for a given integer increment (to increase asset weights from 0%
65
'up to 100%.
66
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sblistassetweightcombinations 05.04.2021 v0.2
67
Dim i As Long, j As Long, lCheckSum As Long, lIncrement As Long
68
Dim lAssets As Long, lSum As Long, lRow As Long, s As Long
69
70
wsC.Range("A4:A1048576").EntireRow.Delete
71
lSum = 100
72
lIncrement = Range("Increment")
73
lAssets = Range("Assets")
74
ReDim lA(1 To lAssets) As Long
75
lCheckSum = Application.WorksheetFunction.Combin(lSum \ lIncrement _
76
+ lAssets - 1, lAssets - 1)
77
If lSum Mod lIncrement <> 0 Then
78
Call MsgBox(lSum & " divided by increment " & lIncrement & _
79
" gives a remainder <> 0!", vbOKOnly, "Error")
80
Exit Sub
81
ElseIf lCheckSum > 1048576 - 4 Then
82
Call MsgBox("I don't have enough rows to list all " & _
83
lCheckSum & " combinations!", vbOKOnly, "Error")
84
Exit Sub
85
ElseIf lCheckSum > 100000 Then
86
If vbCancel = MsgBox("Have you got enough time to wait for " & _
87
lCheckSum & " combinations?", vbOKCancel, "Question") Then
88
Exit Sub
89
End If
90
End If
91
wsC.Cells(4, 1) = "#"
92
For i = 1 To lAssets
93
wsC.Cells(4, 1 + i) = Chr(64 + i)
94
Next i
95
lRow = 5
96
i = 1
97
Do While i <= lAssets
98
lA(i) = lA(i) + lIncrement
99
If lA(i) > lSum Then
100
lA(i) = 0
101
i = i + 1
102
Else
103
s = lA(1)
104
For j = 2 To lAssets
105
s = s + lA(j)
106
Next j
107
If s = lSum Then
108
wsC.Cells(lRow, 1) = lRow - 4
109
For j = 1 To lAssets
110
wsC.Cells(lRow, j + 1) = lA(j)
111
Next j
112
lRow = lRow + 1
113
End If
114
i = 1
115
End If
116
Loop
117
Range("CombinationCount").Value = IIf(lRow - 5 = lCheckSum, lCheckSum, _
118
"Error: I expected " & lCheckSum & " combinations but I counted " & _
119
lRow - 5)
120
End Sub
121
Copied!
sbListAssetWeightCombinations.xlsm
28KB
Binary
sbListAssetWeightCombinations.xlsm