Sulprobil
Search…
sbListAssetWeightCombinations
You need to list all possible combinations of asset weights which need to add up to 100%?
Please read my Disclaimer.
Sub sbListAssetWeightCombinations_Double()
'List all asset weight combinations for a given count of assets and
'for a given (double precision) increment (to increase asset weights from 0%
'up to 100%.
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sblistassetweightcombinations 05.04.2021 v0.2
Dim d As Double, dCheckSum As Double, dIncrement As Double, dSum As Double
Dim i As Long, j As Long
Dim lAssets As Long, lRow As Long
wsD.Range("A4:A1048576").EntireRow.Delete
dSum = 100#
dIncrement = Range("dIncrement")
lAssets = Range("dAssets")
ReDim dA(1 To lAssets) As Double
dCheckSum = Application.WorksheetFunction.Combin(Int(dSum / dIncrement) _
+ lAssets - 1, lAssets - 1)
If Abs(Int(dSum / dIncrement) * dIncrement - dSum) > 0.0000000000001 Then
Call MsgBox(dSum & " divided by increment " & dIncrement & _
" gives a remainder <> 0!", vbOKOnly, "Error")
Exit Sub
ElseIf dCheckSum > 1048576# - 4# Then
Call MsgBox("I don't have enough rows to list all " & _
dCheckSum & " combinations!", vbOKOnly, "Error")
Exit Sub
ElseIf dCheckSum > 100000# Then
If vbCancel = MsgBox("Have you got enough time to wait for " & _
dCheckSum & " combinations?", vbOKCancel, "Question") Then
Exit Sub
End If
End If
wsD.Cells(4, 1) = "#"
For i = 1 To lAssets
wsD.Cells(4, 1 + i) = Chr(64 + i)
Next i
lRow = 5
i = 1
Do While i <= lAssets
dA(i) = dA(i) + dIncrement
If dA(i) > dSum Then
dA(i) = 0#
i = i + 1
Else
d = dA(1)
For j = 2 To lAssets
d = d + dA(j)
Next j
If Abs(d - dSum) < 0.0000000000001 Then
wsD.Cells(lRow, 1) = lRow - 4
For j = 1 To lAssets
wsD.Cells(lRow, j + 1) = dA(j)
Next j
lRow = lRow + 1
End If
i = 1
End If
Loop
Range("dCombinationCount").Value = IIf(lRow - 5 = dCheckSum, dCheckSum, _
"Error: I expected " & dCheckSum & " combinations but I counted " & _
lRow - 5)
End Sub
Sub sbListAssetWeightCombinations_Integer()
'List all asset weight combinations for a given count of assets and
'for a given integer increment (to increase asset weights from 0%
'up to 100%.
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sblistassetweightcombinations 05.04.2021 v0.2
Dim i As Long, j As Long, lCheckSum As Long, lIncrement As Long
Dim lAssets As Long, lSum As Long, lRow As Long, s As Long
wsC.Range("A4:A1048576").EntireRow.Delete
lSum = 100
lIncrement = Range("Increment")
lAssets = Range("Assets")
ReDim lA(1 To lAssets) As Long
lCheckSum = Application.WorksheetFunction.Combin(lSum \ lIncrement _
+ lAssets - 1, lAssets - 1)
If lSum Mod lIncrement <> 0 Then
Call MsgBox(lSum & " divided by increment " & lIncrement & _
" gives a remainder <> 0!", vbOKOnly, "Error")
Exit Sub
ElseIf lCheckSum > 1048576 - 4 Then
Call MsgBox("I don't have enough rows to list all " & _
lCheckSum & " combinations!", vbOKOnly, "Error")
Exit Sub
ElseIf lCheckSum > 100000 Then
If vbCancel = MsgBox("Have you got enough time to wait for " & _
lCheckSum & " combinations?", vbOKCancel, "Question") Then
Exit Sub
End If
End If
wsC.Cells(4, 1) = "#"
For i = 1 To lAssets
wsC.Cells(4, 1 + i) = Chr(64 + i)
Next i
lRow = 5
i = 1
Do While i <= lAssets
lA(i) = lA(i) + lIncrement
If lA(i) > lSum Then
lA(i) = 0
i = i + 1
Else
s = lA(1)
For j = 2 To lAssets
s = s + lA(j)
Next j
If s = lSum Then
wsC.Cells(lRow, 1) = lRow - 4
For j = 1 To lAssets
wsC.Cells(lRow, j + 1) = lA(j)
Next j
lRow = lRow + 1
End If
i = 1
End If
Loop
Range("CombinationCount").Value = IIf(lRow - 5 = lCheckSum, lCheckSum, _
"Error: I expected " & lCheckSum & " combinations but I counted " & _
lRow - 5)
End Sub
sbListAssetWeightCombinations.xlsm
28KB
Binary
sbListAssetWeightCombinations.xlsm
Copy link