How to calculate Variance Covariance Matrix?

Sub covars_etc2()
n = [a2].End(xlDown).Row
a = Range([a2], Cells(n, 5))
Set yr = CreateObject("Scripting.Dictionary")
Set mn = CreateObject("Scripting.Dictionary")
Set stk = CreateObject("Scripting.Dictionary")
For i = 1 To n - 1
     If Not stk.exists(a(i, 1)) Then stk.Add a(i, 1), Empty
    If Not yr.exists(a(i, 2)) Then yr.Add a(i, 2), Empty
    If Not mn.exists(a(i, 3)) Then mn.Add a(i, 3), Empty
Next i

stke = stk.keys:     stc = stk.Count
yrke = yr.keys:  yrc = yr.Count
mnke = mn.keys:  mnc = mn.Count

ReDim x(1 To yrc, 1 To mnc, 1 To stc)
For p = 1 To n - 1
    For q = 1 To yrc
        For r = 1 To mnc
            For s = 1 To stc
                If yrke(q - 1) = a(p, 2) And _
                    mnke(r - 1) = a(p, 3) And _
                        stke(s - 1) = a(p, 1) Then
                    x(q, r, s) = a(p, 4)
                End If
            Next s
        Next r
    Next q
Next p

For q = 1 To yrc
ReDim c(1 To stc, 1 To stc)
    For s1 = 1 To stc
        For s2 = 1 To stc
            ssq = 0
            sa = 0
            sb = 0
            For r = 1 To mnc
                ssq = ssq + x(q, r, s1) * x(q, r, s2)
                sa = sa + x(q, r, s1)
                sb = sb + x(q, r, s2)
            Next r
            c(s1, s2) = (ssq - sa * sb / mnc) / (mnc)
        Next s2
    Next s1

Cells(q * stc + q, 8) = yrke(q - 1)
Cells(q * stc + q, 9).Resize(stc, stc) = c
Next q
End Sub