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
[VBA]
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
[/VBA]
thanks n Regards
Ravinder Singh
Reply With Quote
Originally Posted by Aussiebear
