Option Explicit
Option Base 1
'===============================================================================
'Author: Timothy R. Mayes, Ph.D.
'Website: http://www.tvmcalcs.com/blog/
'Version: 1.0
'Date: 2/5/2009
'This code creats a "live" variance/covariance matrix on your worksheet.
'
'It sets up a range with matrix functions linked to your data, so it will
'update automatically if the data changes.
'
'It can create either a normal var/cov matrix, or a probability weighted var/cov matrix.
'
'It can show the entire matrix, hide the upper part, or hide the lower part.
'
'It can create a population or sample var/cov matrix. Note that Excel only does population.
'
'Formulas (using fake named ranges)
'
'If Data are in columns:
'Equal Weighted: =MMULT(TRANSPOSE(Data - Mean), Data - Mean)/VarCount
'Unequal Weighted: =MMULT(TRANSPOSE(Weights*(Data - Mean)), Data - Mean)
'
'If Data are in rows:
'Equal Weighted: =MMULT(Data - Mean, TRANSPOSE(Data - Mean))/VarCount
'Unequal Weighted: =MMULT(Data - Mean, TRANSPOSE(Weights*(Data - Mean)))
'
'Note: Means are calculated within the formulas as a weighted (equal or unequal) average.
'This makes the actual formulas long and ugly, but don't need a separate range for averages.
'
'Planned Updates:
'None at this time
'
'Acknowledgements:
'Thanks to Dave Peterson for helping me to figure out a hack for the 255 character limit in .FormulaArray by using .Replace and a fake string
'His method was posted at http://www.dailydoseofexcel.com/archives/2005/01/10/entering-long-array-formulas-in-vba/
'===============================================================================
'The global ribbon object
Dim grxIRibbonUI As IRibbonUI
Sub rxIRibbonUI_onload(ribbon As IRibbonUI)
'Set up the ribbon variable so that we can add to it
Set grxIRibbonUI = ribbon
End Sub
Sub rxbtn_CovMatrix(control As IRibbonControl)
'Callback for ExcelSim onAction
'Call the CovMatrix() sub to run the add-in code
Dim w As Workbook
Dim Cnt As Integer
Dim FName As Variant
Cnt = 0
'Count how many regular workbooks are open, not counting personal.xls*
For Each w In Application.Workbooks
FName = Split(w.Name, "."
If (w.IsAddin = False And StrComp(FName(0), "personal", vbTextCompare) <> 0) Then Cnt = Cnt + 1
Next
'If 1 or more regular workbooks, then run the add-in. Otherwise give an error message and exit.
If Cnt > 0 Then
Call CovMatrix
Else
MsgBox "You must have an open workbook to use this add-in", vbOKOnly, "Covariance Matrix Add-in"
Exit Sub
End If
End Sub
Sub CovMatrix()
Dim WeightRng As Range
Dim InputRng As Range
Dim LabelRng As Range
Dim OutputRng As Range
Dim TmpRng As Range
Dim LeftLabels As Range, TopLabels As Range
Dim HasTitle As Byte
Dim HidePartofMatrix As Byte
Dim MeanStr As String
Dim InputSht As String, OutputSht As String, WeightStr As String
Dim NumVars As Integer
Dim i As Integer
Dim LabelArray()
Dim c As Variant
Const FakeStr As String = "X_X_X" 'This is a place holder to make FormulaArray work with formulas > 255 characters, it will be replaced
CovDialog.Show
If CovDialog.CancelPressed Then
Unload CovDialog
Exit Sub
End If
'Get the Data into our range variables
Set InputRng = Range(CovDialog.InputEditBox.Text)
Set OutputRng = Range(CovDialog.OutputEditBox.Text).Cells(1, 1) 'We only want upper-left corner, we will calculate the rest
If CovDialog.WeightsEditBox.Text <> "" Then
Set WeightRng = Range(CovDialog.WeightsEditBox.Text)
Else
Set WeightRng = Nothing
End If
If CovDialog.LabelsBox = True Then 'Set LabelRng and Resize InputRng to remove labels
If CovDialog.ColumnButton = True Then 'Labels in first row
Set LabelRng = Range(InputRng.Cells(1, 1), InputRng.Cells(1, InputRng.Columns.Count))
Set InputRng = Range(InputRng.Cells(2, 1), InputRng.Cells(InputRng.Rows.Count, InputRng.Columns.Count))
NumVars = InputRng.Columns.Count
Else 'Labels in first column
Set LabelRng = Range(InputRng.Cells(1, 1), InputRng.Cells(InputRng.Rows.Count, 1))
Set InputRng = Range(InputRng.Cells(1, 2), InputRng.Cells(InputRng.Rows.Count, InputRng.Columns.Count))
NumVars = InputRng.Rows.Count
End If
Else
'Labels not selected, so no LabelRng
Set LabelRng = Nothing
If CovDialog.ColumnButton = True Then NumVars = InputRng.Columns.Count Else NumVars = InputRng.Rows.Count
End If
If CovDialog.TitleBox = True Then HasTitle = 1 Else HasTitle = 0 '1 if has a title, 0 otherwise
'Get Sheet Names for input data and output data. Note that we are grabbing the first cell in the zero-based array.
InputSht = Split(CovDialog.InputEditBox.Text, "!"
(0)
OutputSht = Split(CovDialog.OutputEditBox.Text, "!"
(0)
If Not WeightRng Is Nothing Then WeightStr = Split(CovDialog.WeightsEditBox.Text, "!"
(0)
'If sheet names are the same, set InputSht to InputRng.Address because we don't need the sheet name.
If StrComp(InputSht, OutputSht, vbTextCompare) = 0 Then
InputSht = InputRng.Address
If Not WeightRng Is Nothing Then WeightStr = WeightRng.Address
Else 'Sheet names are different, add sheet name to addresses if possible
If InStr(CovDialog.InputEditBox.Text, "!"
Then InputSht = InputSht + "!" + InputRng.Address Else InputSht = InputRng.Address
If Not WeightRng Is Nothing Then
If InStr(CovDialog.WeightsEditBox.Text, "!"
Then WeightStr = WeightStr + "!" + WeightRng.Address Else WeightStr = WeightRng.Address
End If
End If
If CovDialog.AllButton = True Then
HidePartofMatrix = 0 'Show all of matrix
Else
If CovDialog.LowerButton = True Then
HidePartofMatrix = 1 'Show only lower half of matrix
Else
HidePartofMatrix = 2 'Show only upper half of matrix
End If
End If
'Build the string that calculates the mean to simplify the actual formula string
If CovDialog.ColumnButton = True Then 'Variables in Columns
If WeightRng Is Nothing Then
'Equal weighted
MeanStr = "MMULT(TRANSPOSE(N(ISNUMBER(ROW(" + InputSht + "
))/ROWS(" + InputSht + "
)," + InputSht + "
"
Else
'Unequal weights
MeanStr = "MMULT(TRANSPOSE(" + WeightStr + "
," + InputSht + "
"
End If
Else 'Variables in Rows
If WeightRng Is Nothing Then
'Equal weighted
MeanStr = "MMULT(" + InputSht + ",TRANSPOSE(N(ISNUMBER(COLUMN(" + InputSht + "
))/COLUMNS(" + InputSht + "
))"
Else
'Unequal weights
MeanStr = "MMULT(" + InputSht + ",TRANSPOSE(" + WeightStr + "
)"
End If
End If
'Calculate Output Range and write labels and formulas
ReDim LabelArray(1 To NumVars)
If LabelRng Is Nothing Then 'If labels aren't supplied, give defaults
For i = 1 To NumVars
LabelArray(i) = "Var " + VBA.Format(i, "#"
Next
Else 'Otherwise, place the given labels into LabelArray
i = 0
For Each c In LabelRng
i = i + 1
LabelArray(i) = c.Text
Next
End If
'This section is where we create, format, and write the output
'If output area has data, then clear the range where we will write the results
Set TmpRng = Range(OutputRng.Offset(0, 0), OutputRng.Offset(NumVars + HasTitle, NumVars))
If Application.WorksheetFunction.CountBlank(TmpRng) = TmpRng.Count Then
TmpRng.Clear
Else
i = MsgBox("The output range contains data. Click OK to overwrite.", vbOKCancel)
If i = 2 Then
Exit Sub 'Exit if user doesn't want to overwrite existing data
Else
On Error Resume Next
TmpRng.Clear
If Err.Number <> 0 Then 'Probably can't clear because there is overlap with an array formula
MsgBox "Cannot clear the output range. Try manually clearing it, or change output range. Exiting routine." + VBA.Chr(13) + VBA.Chr(13) + "Error: " + Err.Description, vbOKOnly
Exit Sub
End If
End If
End If
Application.ScreenUpdating = False
Set LeftLabels = Range(OutputRng.Offset(1 + HasTitle, 0), OutputRng.Offset(NumVars + HasTitle, 0))
Set TopLabels = Range(OutputRng.Offset(0 + HasTitle, 1), OutputRng.Offset(0 + HasTitle, NumVars))
LeftLabels.Value = WorksheetFunction.Transpose(LabelArray) 'Write left column labels
TopLabels.Value = LabelArray 'Write top row labels
Set OutputRng = Range(OutputRng.Offset(1 + HasTitle, 1), OutputRng.Offset(NumVars + HasTitle, NumVars))
If WeightRng Is Nothing Then
'Equal weighted covariance
If CovDialog.ColumnButton = True Then 'Variables in columns
If CovDialog.PopButton Then
OutputRng.FormulaArray = "=MMULT(TRANSPOSE(" + InputSht + "-" + FakeStr + "
,(" + InputSht + "-" + FakeStr + "
)/Rows(" + InputSht + "
"
Else
OutputRng.FormulaArray = "=MMULT(TRANSPOSE(" + InputSht + "-" + FakeStr + "
,(" + InputSht + "-" + FakeStr + "
)/(Rows(" + InputSht + "
-1)"
End If
Else 'Variables in rows
If CovDialog.PopButton Then
OutputRng.FormulaArray = "=MMULT(" + InputSht + "-" + FakeStr + ",transpose(" + InputSht + "-" + FakeStr + "
)/Columns(" + InputSht + "
"
Else
OutputRng.FormulaArray = "=MMULT(" + InputSht + "-" + FakeStr + ",transpose(" + InputSht + "-" + FakeStr + "
)/(Columns(" + InputSht + "
-1)"
End If
End If
Else
'Not equal weighted covariance
If CovDialog.ColumnButton = True Then 'Variables in columns
OutputRng.FormulaArray = "=MMULT(TRANSPOSE(" + WeightStr + "*(" + InputSht + "-" + FakeStr + "
),(" + InputSht + "-" + FakeStr + "
)"
Else 'Variables in rows
OutputRng.FormulaArray = "=MMULT(" + InputSht + "-" + FakeStr + ",TRANSPOSE(" + WeightStr + "*(" + InputSht + "-" + FakeStr + "
))"
End If
End If
OutputRng.Replace FakeStr, MeanStr 'This replaces the FakeStr that we put in to shorten the formula so that FormulaArray would work
'Format the output
With LeftLabels
.Font.FontStyle = "Bold Italic"
.HorizontalAlignment = xlRight
End With
With TopLabels
.Font.FontStyle = "Bold Italic"
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlThin
.HorizontalAlignment = xlCenter
End With
With TopLabels.Offset(0, -1)
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlThin
End With
If HasTitle = 1 Then 'Add a title, if requested
If WeightRng Is Nothing Then
If CovDialog.PopButton Then
TopLabels.Offset(-1, -1).Cells(1, 1).Value = "Population Variance/Covariance Matrix"
Else
TopLabels.Offset(-1, -1).Cells(1, 1).Value = "Sample Variance/Covariance Matrix"
End If
Else
TopLabels.Offset(-1, -1).Cells(1, 1).Value = "Weighted Variance/Covariance Matrix"
End If
With Range(TopLabels.Offset(-1, -1), TopLabels.Offset(-1, 0))
.Font.FontStyle = "Bold Italic"
.HorizontalAlignment = xlHAlignCenterAcrossSelection
End With
End If
With OutputRng 'Format the numbers and add a border at bottom
.NumberFormat = "0.00000_)"
.Borders(xlEdgeBottom).Weight = xlMedium
End With
OutputRng.Offset(0, -1).Borders(xlEdgeBottom).Weight = xlMedium
If HidePartofMatrix = 1 Then 'Hide upper half of matrix
For i = 1 To NumVars - 1
With Range(OutputRng.Cells(i, 1 + i), OutputRng.Cells(i, NumVars))
.Font.Color = .Interior.Color
End With
Next i
End If
If HidePartofMatrix = 2 Then 'Hide lower half of matrix
For i = 2 To NumVars
With Range(OutputRng.Cells(i, 1), OutputRng.Cells(i, i - 1))
.Font.Color = .Interior.Color
End With
Next i
End If
Application.ScreenUpdating = True
Unload CovDialog
End Sub
