用EXCEL VBA 计算一组数据的自相关函数和偏自相关函数

-5.552941176
-3.352941176
-1.552941176
-4.152941176
-1.552941176
-4.152941176
-3.152941176
-2.152941176
-1.152941176
-0.152941176
0.847058824
1.847058824
2.847058824
3.847058824
4.847058824
5.847058824
6.847058824

data mydata;
input x;
cards;
-5.552941176
-3.352941176
-1.552941176
-4.152941176
-1.552941176
-4.152941176
-3.152941176
-2.152941176
-1.152941176
-0.152941176
0.847058824
1.847058824
2.847058824
3.847058824
4.847058824
5.847058824
6.847058824
;
run;
proc arima;
identify var = x nlag = 864 outcov = out1;
run;

计算自相关函数的的自定义函数是acf()，偏自关函数是pacf()，它们的参数都是一组数据，而这组数据来自excel中的单元格范围，故它们都调用了一个函数，用来将excel的单元格范围转化成一个数组，这个函数就是range2array()。

range2array()的算法很简单，用for each循环将range中的每一个数字逐个填充到预先定义好的array()中。而这个array()的大小，与range中的单元格数相同。

acf()的算法，即是根据样本自相关函数的定义而实现的。即

而pacf()的算法，也是根据偏自相关函数的定义来的。即

在pacf()中，先根据输入的参数数组，分别得到分母矩阵和分子矩阵，然后分别对分母矩阵和分子矩阵求行列式值。最后相除即可。

分母矩阵实际上是一个对称矩阵，而且观察后可以发现有这样的规律，即，每个元素的下标，都是其行列号的差的绝对值。

而分子矩阵，除了最后一列，其他的元素都与分母矩阵相同。

Option Explicit
'Option Private Module

'''''''''''''''''''''''''''''''''' ' 计算列数据的自相关函数 ' '''''''''''''''''''''''''''''''''' Public Function ACF(ByRef rng As Range, ByVal k As Long) As Double Dim dDenominator As Double Dim dNumerator As Double Dim daX() As Variant Dim i As Long Dim lUB As Long, lLB As Long

daX = Range2Array(rng)

'计算分子
dNumerator = 0
lUB = UBound(daX)
lLB = LBound(daX)
For i = lLB + k To lUB
    dNumerator = dNumerator + daX(i) * daX(i - k)
Next i

'计算分母
dDenominator = 0
For i = lLB To lUB
    dDenominator = dDenominator + daX(i) * daX(i)
Next i

ACF = dNumerator / dDenominator

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' 计算列数据的偏自相关函数 ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function PACF(ByRef rng As Range, ByVal k As Long) As Double Dim dDenominator As Double Dim dNumerator As Double Dim dMatrixDenominator() As Double Dim dMatrixNumerator() As Double Dim vArray() As Variant Dim i As Long, j As Long Dim sString As String

vArray = Range2Array(rng, 1)
vArray(LBound(vArray)) = 1

ReDim dMatrixDenominator(0 To k - 1, 0 To k - 1)
ReDim dMatrixNumerator(0 To k - 1, 0 To k - 1)

'生成分母矩阵

' sString = "分母矩阵:" & vbCrLf

For i = 0 To k - 1
    For j = 0 To k - 1
        dMatrixDenominator(i, j) = CDbl(vArray(Abs(i - j)))

' sString = sString & dMatrixDenominator(i, j) & vbTab Next j ' sString = sString & vbCrLf Next i ' Debug.Print sString

'生成分子矩阵
For i = 0 To k - 1
    For j = 0 To k - 2
        dMatrixNumerator(i, j) = CDbl(vArray(Abs(i - j)))
    Next j
Next i
For i = 0 To k - 1
    dMatrixNumerator(i, k - 1) = CDbl(vArray(i + 1))
Next i

' sString = "分子矩阵:" & vbCrLf ' For i = 0 To k - 1 ' For j = 0 To k - 1 ' sString = sString & dMatrixNumerator(i, j) & vbTab ' Next j ' sString = sString & vbCrLf ' Next i ' Debug.Print sString

'计算PACF(k,k)
PACF = Application.WorksheetFunction.MDeterm(dMatrixNumerator) / Application.WorksheetFunction.MDeterm(dMatrixDenominator)

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' 求和 ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function SigmaSum(ByRef rng As Range, ByVal lBegin As Long, ByVal lEnd As Long, ByVal power As Double) As Double SigmaSum = 0

Dim i As Long

For i = lBegin To lEnd
    SigmaSum = SigmaSum + CDbl(rng.Cells(i).Value) ^ power
Next i

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' 将Range转换成数组 (变体型) ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Function Range2Array(ByRef rng As Range, Optional ByVal lOffset As Long = 0) As Variant() Dim vaRet() As Variant Dim i As Long Dim rngCell As Range

ReDim vaRet(0 To rng.Cells.Count - 1)
i = lOffset
For Each rngCell In rng
    vaRet(i) = rngCell.Value
    If i >= UBound(vaRet) Then
        Exit For
    End If
    i = i + 1
Next rngCell

Range2Array = vaRet

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' 将Range转换成数组 (双精度型) ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Function Range2ArrayDouble(ByRef rng As Range) As Double() Dim daRet() As Double Dim i As Long Dim rngCell As Range

ReDim vaRet(0 To rng.Cells.Count - 1)
i = 0
For Each rngCell In rng
    On Error Resume Next
    daRet(i) = CDbl(rngCell.Value)
    If Err.Number <> 0 Then
        daRet(i) = 0
        Err.Clear
    End If
    i = i + 1
Next rngCell

Range2ArrayDouble = daRet

End Function