Portfolio Optimization in VBA

Use this Excel program to calculate the mean-variance optimizing portfolio from your own selection of assets.

Download Excel Spreadsheet to maximize your Sharpe ratio



Public Price() As Double, Returns() As Double, Avg_Return() As Double
Public Names() As String, Names_Data() As Variant
Public Covariance() As Double, Dates() As Double
Public Data() As Variant, Dates_Data() As Variant
Public i, j, k, l, m, n, o, p, Scaling_Term As Integer
Public num_assets, num_periods As Integer
Public weight() As Double, Portfolio_Return As Double
Public Portfolio_StDev As Double, Sharpe As Double
    
Sub OptimumPortfolio()
    
'Sets main values
    Sheets(1).Activate
    num_assets = Application.WorksheetFunction.Count(Range("B3:CCC3"))
    num_periods = Application.WorksheetFunction.Count(Range("B3:B10000"))
'
    
'Sets Dimensions for Matrices
    ReDim Names(num_assets) As String
    ReDim Price(num_assets, num_periods) As Double
    ReDim Dates(num_periods) As Double
    ReDim Returns(num_assets, num_periods) As Double
    ReDim Avg_Return(num_assets) As Double
    ReDim Covariance(num_assets, num_assets) As Double
    ReDim weight(num_assets) As Double
'
    
'Ensures Data Quality
    For i = 1 To num_assets
        For j = 1 To num_assets
            Covariance(i, j) = 0
        Next j
        Avg_Return(i) = 0
    Next i
'
    
'Loads Data From File
    Sheets(1).Activate
    Data = Range(Cells(3, 2), Cells(num_periods + 2, num_assets + 1))
    Dates_Data = Range("A3:A" & num_periods + 2)
    Names_Data = Range(Cells(2, 2), Cells(2, num_assets + 1))
'
    
'Sets Scaling Term - Daily Data
    Scaling_Term = 252
'
    
'Sets Price Matrix Values from Spreadsheet
    For i = 1 To num_assets
        Names(i) = Names_Data(1, i)
        For j = 1 To num_periods
            Price(i, j) = Data(j, i)
        Next j
    Next i
'

'Calculates One Period Returns
    For i = 1 To num_assets
        For j = 2 To num_periods
            Returns(i, j) = (Price(i, j) - Price(i, j - 1)) / Price(i, j - 1)
        Next j
    Next i
'
    
'Calculates Average Return
    For i = 1 To num_assets
        For j = 2 To num_periods
            Avg_Return(i) = Avg_Return(i) + Returns(i, j)
        Next j
            Avg_Return(i) = Avg_Return(i) / (num_periods - 1)
    Next i
'
    
'Finds the Covariance Matrix
    For i = 1 To num_assets
        For j = 1 To num_assets
            For k = 2 To num_periods
                Covariance(i, j) = Covariance(i, j) + _
                    (Returns(i, k) - Avg_Return(i)) * (Returns(j, k) - Avg_Return(j))
            Next k
                Covariance(i, j) = Scaling_Term * Covariance(i, j) / (num_periods - 1)
        Next j
    Next i
'
    
'Creates WIP Worksheet
    Sheets("WIP").Range("A1:AAA1000").Clear
    Sheets("WIP").Activate
'
        
'Prints Covariance Matrix
    Range("A1").Value = "Covariance Matrix"
    For i = 1 To num_assets
        For j = 1 To num_assets
            Cells(1 + i, 1 + j).Value = Covariance(i, j)
        Next j
    Next i
'
        
'Prints Weights Array and Weights Tranpose Array
    For i = 1 To num_assets
        Range("B" & 3 + num_assets * 2 + i).Value = "Weight " & i
        Range("C" & 3 + num_assets * 2 + i).Value = 1
        Cells(11 + num_assets * 3, 1 + i).Value = _
            "=R[" & -8 - num_assets + i & "]C[" & 2 - i & "]"
        Range("A" & 4 + num_assets * 2).Value = _
            "=Sum(RC[2]:R[" & num_assets - 1 & "]C[2])"
    Next i
'
    
'Prints Average Return Array
   For i = 1 To num_assets
       Range("E" & 3 + num_assets * 2 + i).Value = "AvgR " & i
       Range("F" & 3 + num_assets * 2 + i).Value = Avg_Return(i) * Scaling_Term
   Next i
'
    
'Calculates Portfolio's Return Given Weights
   Range("B" & 5 + num_assets * 3).Value = "R_Portf"
   Range("C" & 5 + num_assets * 3).Value = _
       "=SUMPRODUCT(R[" & -1 - num_assets & "]C[3]:R[-2]C[3]," & _
       "R[" & -1 - num_assets & "]C[0]:R[-2]C[0])"
'
    
'Calculates Portfolio's Standard Deviation Given Weights
    Range(Cells(6 + num_assets * 3, 3), Cells(6 + num_assets * 3, 2 + num_assets)).Select
        Selection.FormulaArray = "=(MMULT(R[5]C[-1]:R[5]C[" & -2 + num_assets & "]," & _
            "R[" & -4 - (num_assets * 3) & "]C[-1]:" & _
            "R[" & -5 - (num_assets * 2) & "]C[" & num_assets - 2 & "]))"
    Range("B" & 7 + num_assets * 3).Value = "Var_Portf"
    Range("C" & 7 + num_assets * 3).Value = "=MMULT(R[-1]C:R[-1]C[" & num_assets - 1 & "]," & _
        "R[" & -3 - num_assets & "]C:R[-4]C)"
    Range("B" & 8 + num_assets * 3).Value = "Std_Portf"
    Range("C" & 8 + num_assets * 3).Value = "=sqrt(R[-1]C)"
'
    
'Calculates the Portfolio's Sharpe Ratio Given Weights
   Range("B" & 9 + num_assets * 3).Value = "Sharpe"
   Range("C" & 9 + num_assets * 3).Value = "=R[-4]C/R[-1]C"
'

'Maximizes the Sharpe Ratio by Changing the Weights. Maximum Value is 1, Minimum Value is -1
    SolverReset
    SolverOk SetCell:=Range("C" & 9 + num_assets * 3), MaxMinVal:=1, _
        ByChange:=Range("C" & 4 + num_assets * 2 & ":C" & 3 + num_assets * 3)
    
    For a = 1 To num_assets
        SolverAdd CellRef:=Cells(3 + num_assets * 2 + a, 3), Relation:=1, FormulaText:="1"
        SolverAdd CellRef:=Cells(3 + num_assets * 2 + a, 3), Relation:=3, FormulaText:="-1"
    Next a
        SolverAdd CellRef:=Cells(4 + num_assets * 2, 1), Relation:=2, FormulaText:="1"
   
   SolverSolve
'
        
'Copies Results
    For i = 1 To num_assets
        weight(i) = Range("C" & 3 + num_assets * 2 + i).Value
    Next i
    Portfolio_Return = Range("C" & 5 + num_assets * 3).Value
    Portfolio_StdDev = Range("C" & 8 + num_assets * 3).Value
    Sharpe = Range("C" & 9 + num_assets * 3).Value
'
    
'Opens Results Worksheet
    Sheets("Results").Range("A1:AAA1000").Clear
    Sheets("Results").Activate
'
    
'Shows Results
    'Prints Ideal Weights
        Range("A1:B1").Merge
        With Range("A1")
            .Value = "Assets"
            .Font.Size = 20
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
        Range("A2").Value = "Ticker"
        Range("A2").Font.Bold = True
        Range("B2").Value = "Weight"
        Range("B2").Font.Bold = True
    
        For i = 1 To num_assets
            Range("A" & 2 + i).Value = Names(i)
            Range("B" & 2 + i).Value = weight(i)
        Next i
        Range("B2:B" & num_assets + 2).NumberFormat = "0.0%"
        Range("A2:B" & num_assets + 2).HorizontalAlignment = xlCenter
    '
    
    'Prints Portfolio Statistics
        Range("D1:E1").Merge
        With Range("D1")
            .Value = "Portfolio"
            .Font.Size = 20
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
            
        Range("D2").Value = "Return"
        Range("D3").Value = "Standard Deviation"
        Range("D4").Value = "Sharpe Ratio"

        Range("E2").Value = Portfolio_Return
        Range("E3").Value = Portfolio_StdDev
        Range("E4").Value = Sharpe
        Range("E2:E4").NumberFormat = "0.00"
    '
    
    'Complete Formatting
        Cells.Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
        End With
    
        Range("A1:B" & num_assets + 2).Select
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Interior
            .Pattern = xlSolid
            .Color = 9497732
        End With
        
        Range("D1:E4").Select
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .weight = xlMedium
        End With
        With Selection.Interior
            .Pattern = xlSolid
            .Color = 15656648
        End With
    '
'

End Sub