PDA

View Full Version : AutoCorrelation and Partial AutoCorrelation series Generation



ravinder_tig
08-10-2009, 01:05 AM
Hi Guys
I'm Quite new to excel i do have a project
for which i had to generate a AutoCorrelation and Partial AutoCorrelation series,
i had develope da code for acf and its working quite gud
but my problem is PACF which i found on net and modified according to my use
but my problem is i'm getting the right values for only few values
else values like in curent example 63 in pacf column(4th to last value ) is quite large
and its also showing the error regarding the secong value although i had override the error by
Error Handling but still not reaching to any solution
I'd be really Gr8fulif any one of you could help me in this case i'm attaching the Code and file
Your help would be gr8ly appriciated

Code

Const MaxNumPoints = 500
Sub Cmd()

Dim Cov(0 To MaxNumPoints) As Double, _
Rcoeff(0 To MaxNumPoints) As Double, _
Serr(0 To MaxNumPoints) As Double, _
QSerr(0 To MaxNumPoints) As Double, _
Yobsn(1 To MaxNumPoints) As Double, _
YMean As Double, _
Rc As Double
Dim i As Long, _
j As Long, _
k As Long, _
A As Long, _
NumPoints As Long, _
NumRs As Long

Dim YStartCell As String, _
ACFStartCell As String, _
MyC1 As String, _
MyC2 As String

Dim F1 As Variant, _
F2 As Variant, _
F3 As Variant

On Error Resume Next

With ThisWorkbook.Sheets("Autocorrelation")
Set F1 = .Range("A1:E65536").Find("Actual", LookIn:=xlValues, _
Lookat:=xlWhole, _
MatchCase:=True, _
SearchFormat:=True)
If Not F1 Is Nothing Then
SRow = F1.Row + 1
SCol = F1.Column
MyC1 = Split(Columns(SCol).Address(False, False), ":")(0)
MyC2 = Split(Columns(SCol + 1).Address(False, False), ":")(0)
ERow = .Cells(.Rows.Count, SCol).End(xlUp).Row
Else
SwOk = False
End If
R1 = MyC1 & SRow
R2 = MyC2 & SRow
NumPoints = ERow - 1
YStartCell = R1
ACFStartCell = R2
For i = 1 To NumPoints
Yobsn(i) = .Range(YStartCell).Cells(i, 1).Value
Next i
'NumRs = NumPoints / 3
NumRs = NumPoints - 1
YMean = 0#
For i = 1 To NumPoints
YMean = YMean + Yobsn(i)
Next i
YMean = YMean / NumPoints
For k = 0 To NumRs
Cov(k) = 0
For j = k + 1 To NumPoints
Cov(k) = Cov(k) + (Yobsn(j) - YMean) * (Yobsn(j - k) - YMean)
Next j
Cov(k) = Cov(k) / NumPoints
Next k
For k = 0 To NumRs
Rcoeff(k) = Cov(k) / Cov(0)
.Range(ACFStartCell).Cells(1 + k, 1) = k
.Range(ACFStartCell).Cells(1 + k, 2) = Rcoeff(k)
Next k
For k = 0 To NumRs
Rc = 0
For A = 0 To k - 1
Rc = Rc + ((Rcoeff(A)) ^ 2)
Next A
Serr(k) = ((1 + 2 * (Rc)) / NumPoints) ^ (1 / 2)
.Range(ACFStartCell).Cells(1 + k, 3) = Serr(k)
.Range(ACFStartCell).Cells(1 + k, 4) = -Serr(k)
.Range(ACFStartCell).Cells(1 + k, 5) = Rcoeff(k) / Serr(k)
Next k
For k = 0 To NumRs
Rc = 0
For A = 0 To k
Rc = Rc + (((Rcoeff(A)) ^ 2) / (NumPoints - A))
Next A
QSerr(k) = NumPoints * (NumPoints + 2) * Rc
.Range(ACFStartCell).Cells(1 + k, 6) = QSerr(k)
Next k
End With
End Sub
Sub Partial()

Dim SwOk As Boolean

Dim myDataRange As Range, _
myPosRange As Range

Dim SRow As Integer, _
SCol As Integer, _
ERow As Integer

Dim i As Long, _
Row As Long

Dim A As Double

Dim MyC1 As String, _
MyC2 As String, _
Rng As String
Dim F1 As Variant

SwOk = True

With ThisWorkbook.Sheets("Autocorrelation")

Set F1 = .Range("A1:Z1").Find("ACF", LookIn:=xlValues, _
Lookat:=xlWhole, _
MatchCase:=True, _
SearchFormat:=True)
If Not F1 Is Nothing Then
SRow = F1.Row + 1
SCol = F1.Column
MyC1 = Split(Columns(SCol).Address(False, False), ":")(0)
MyC2 = Split(Columns(SCol + 5).Address(False, False), ":")(0)
ERow = .Cells(.Rows.Count, SCol).End(xlUp).Row
Else
SwOk = False
End If

Rng = MyC1 & SRow & ":" & MyC1 & ERow

Set myDataRange = .Range(Rng)
For i = 1 To ERow - 1

A = PACF(myDataRange, i)
Rng_Dest = MyC2 & i + 1
If A > 10000 Then
.Range(Rng_Dest).Value = 0.22
Else
.Range(Rng_Dest).Value = A
End If
Next i
End With
End Sub
Public Function PACF(Rng As Range, k As Long) As Double

Dim i As Long, _
j As Long

Dim dDenominator As Double, _
dNumerator As Double, _
dMatrixDenominator() As Double, _
dMatrixNumerator() As Double

Dim sString As String

Dim vArray() As Variant

'On Error Resume Next ' Err Handler

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)

For i = 0 To k - 1
For j = 0 To k - 1
dMatrixDenominator(i, j) = CDbl(vArray(Abs(i - j)))
Next j
Next i
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
PACF = Application.WorksheetFunction.MDeterm(dMatrixNumerator) / _
Application.WorksheetFunction.MDeterm(dMatrixDenominator)

End Function

Private Function Range2Array(ByRef Rng As Range, Optional ByVal lOffset As Double = 0) As Variant()

Dim vaRet() As Variant

Dim i As Double

Dim rngCell As Range

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

Range2Array = vaRet
End Function




thanks n Regards
Ravinder Singh

mdmackillop
08-10-2009, 05:44 AM
Gr8fulif
Please don't use this style of text in your questions.

Aussiebear
08-10-2009, 02:18 PM
Did you miss "Dim SwOk As Boolean" in the Sub Cmd() by accident?

ravinder_tig
08-10-2009, 08:18 PM
Did you miss "Dim SwOk As Boolean" in the Sub Cmd() by accident?

No i'm just testing this application so i had closed the option explicit

Aussiebear
08-11-2009, 04:42 AM
When you hold the mouse over the code in the code window, do you find the values of each of the variables?

ravinder_tig
08-11-2009, 05:40 PM
thanks so much for reply Aussie but else ways code is working fine with each level i do need help with PACF function