Option Explicit

Const CMaxDouble = 1.79769313486231E+308
Function sbRebalancedReturn(rARM As Range, _
    rIWV As Range, _
    Optional ByVal lRF As Long = 0, _
    Optional dDT As Double = CMaxDouble) As Variant
'RebalancedReturn calculates balanced returns for a
'portfolio with given
'rARM - asset return matrix (columns show different
'       assets, rows show returns per asset over time)
'rIWV - initial weight vector for the assets
'lRF  - rebalancing frequency (in time steps = rows)
'       If lRF > 0 then each lRF time step rebalancing
'       will take place
'       If lRF = 0 then no rebalancing will take place
'       If lRF < 0 then each -lRF time step after last
'       rebalance portfolio will be rebalanced again
'dDT  - drift tolerance %, if any asset has drifted by
'       by more than dDT (relative measure) then the
'       portfolio will be rebalanced AND the internal
'       rebalancing frequency count will be reset
'The output matrix shows portfolio returns % in first
'column, then end-of-period asset weights and finally
'boolean output values in last column, showing whether
'a rebalance happened.
'This function has been inspired by Andreas Steiner's
'similar function.
'Source (EN): http://www.sulprobil.com/sbrebalancedreturn_en/
'Source (DE): http://www.bplumhoff.de/sbrebalancedreturn_de/
'(C) (P) by Bernd Plumhoff 19-Mar-2011 PB V0.2
Dim i As Long, j As Long, k As Long, n As Long, m As Long
Dim bDrifted As Boolean, bForceRB As Boolean

n = rARM.Rows.Count 'Number of observations
m = rARM.Columns.Count 'Number of assets

If m <> rIWV.Columns.Count Or _
    rIWV.Rows.Count <> 1 Then
    sbRebalancedReturn = CVErr(xlErrValue)
    Exit Function
End If

ReDim w0(1 To m) As Double, x(1 To m) As Double
ReDim r(1 To n, 1 To m) As Double

If lRF = 0 Then lRF = n
If lRF < 0 Then
    lRF = -lRF
    bForceRB = True
Else
    bForceRB = False
End If

ReDim vR(1 To n, 1 To m + 2)
For i = 1 To m
    x(i) = rIWV(i)
    w0(i) = x(i)
    For j = 1 To n
        r(j, i) = rARM(j, i)
    Next j
Next i

k = 1
'Model rebalancing tolerance
For i = 1 To n
    If bDrifted And bForceRB Then k = i
    'Calculate period start weights
    vR(i, m + 2) = (i - k) Mod lRF = 0 Or bDrifted
    If vR(i, m + 2) Then
        For j = 1 To m
            x(j) = w0(j)
        Next j
    Else
        For j = 1 To m
            x(j) = vR(i - 1, 1 + j)
        Next j
    End If
    'Calculate portfolio return
    For j = 1 To m
        vR(i, 1) = vR(i, 1) + x(j) * r(i, j)
    Next j
    'Calculate period end weights & check for drift
    bDrifted = False
    For j = 1 To m
        vR(i, 1 + j) = x(j) * (1# + r(i, j)) / (1# + vR(i, 1))
        bDrifted = bDrifted Or Abs(vR(i, 1 + j) - w0(j)) > dDT
    Next j
Next i
sbRebalancedReturn = vR
End Function