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

28KB

sbListAssetWeightCombinations.xlsm

sbListAssetWeightCombinations.xlsm