Option Base 1Option Explicit
' Simple Linear Regression Estimation with optional parameters
' Error Tests Done: Both inputs should be Vector Range, AllCells within ranges should be not empty,
' This function calculates a number of statics based on the inputs
' Y is the dependend variable
' X is the independent variable
' Output= ax+b, SE(a),SE(B), SE(Y), R^2, SSE,SSR, F
Function LINEST2(y As Variant, Optional x As Variant, Optional constB As Boolean = True, Optional stats As Boolean = False)
'Check inputs for being range
If (TypeName(x) <> "Range") Or (TypeName(y) <> "Range") Then
LINEST2 = CVErr(xlErrValue)
Exit Function
End If
'Make sure each input is a vector, and the same size
If (y.Count <> x.Count) Or (x.Columns.Count <> 1) Or (x.Columns.Count <> y.Columns.Count) Then
LINEST2 = CVErr(xlErrValue)
Exit Function
End If
Application.ScreenUpdating = False 'We don't really need this as the linest doesn't
'update anything in excel file during the processing
Dim RetCells(5, 2) As Variant 'This is the variable that hold the end results
Dim sx, sy, sxx, sxy, syy 'sx = Sum(xi) , sy = Sum(y) ,Sum(xi*yi), Sxx = Sum(x^2) , syy = Sum(y^2)
Dim xVal As Double, yVal As Double 'The points oair values (xi, yi)
Dim errStatus As Boolean 'True in case of an error
Dim i As Double 'i, the dummy variable in the for loops
Dim n 'n, holds the number of point pairs (x,y)
n = y.Count
For i = 1 To n
'Test to see if the cell is not empty, and contain a number
If (TypeName(y(i, 1).Value) <> "Double") Or (TypeName(y(i, 1).Value) <> "Double") Then
LINEST2 = CVErr(xlErrValue)
Exit Function
End If
xVal = x(i) 'We don't want y(i),x(i) to be executed multiple times in the for loop
yVal = y(i) 'A smart compiler would fetch x(i),y(i) only once and put it in a CPU register, but vba isn't
'This reduces the calculation time by removing linked list access time
'With this two lines the calculation time goes from 0.015sec to 0.007 seconds
sx = sx + xVal 'Sum(xi)
sxx = sxx + xVal * xVal 'Sum(xi^2)
sy = sy + yVal 'Sum(yi)
syy = syy + yVal * yVal 'Sum(yi^2)
sxy = sxy + xVal * yVal 'Sum(xi*yi)
Next i
' We want to model the data by, y= ax + b
' To be efficient, we are using formulas which require least amount
' of variables in the for loop, and least amount of function call.
' We have calculated Sx, Sy , Sxx, Sxy, Syy, where S stands for sum.
' det =Sxx N - Sx^2
' beta = (Sxy N - Sy Sx)/det alpha = (Sxx Sy - Sx Sxy)/det
Dim a, b, det, RR, SS, DegreeofFreedom, SEy, SEa, SEb As Double
Dim SSE, SST, SSR, F, SSTx
SSR = SSE = SST = 0
'Error Checking for 0
det = sxx * n - sx * sx
Dim numVariables
'Does the user set the optional parameter of interecept to zero or not
If (constB = True) Then 'If the intercept can be non-zero then:
a = (sxy * n - sy * sx) / det
b = (sy - a * sx) / n ' real(jacobian) solution is b = (sxx * sy - sx * sxy) / det
' but this works too, and is more efficient, and is dependend on slope
numVariables = 2
Else
a = sxy / sxx ' if b=0, ** Need to investigate why sy / sx doesn't work, but sxy/sxx does
numVariables = 1 ' We only have one degree of freedom ( slope )
b = 0 ' The intercept is forced through zero
'b = (sy - a * sx) / n ' we can calculate b just to make sure
End If
If (stats = False) Then 'don't Calculate other stats if the user doesn't require it
For i = 1 To 5
RetCells(i, 1) = a
RetCells(i, 2) = b
Next i
GoTo returnFromFunction
End If
SSE = syy - b * sy - a * sxy 'Error Sum of Squares
SST = syy - (sy ^ 2) / n 'Total Sum of Squares
SSR = SST - SSE
SS = SSE / (n - numVariables) 'S^2
SEy = Sqr(SS) 'Calculation of SEy
SSTx = sxx - (sx ^ 2) / n 'This is an intermediate variable used in SEa,and SEb
RR = 1 - SSE / SST 'r^2 , coefficient of determination
RetCells(2, 1) = SEy / Sqr(SSTx) 'Calculation of SE(a)
RetCells(2, 2) = SEy * Sqr((1 / n) + ((sx / n) ^ 2) / (SSTx)) 'Calculation of SE(b)
' Populate the return array with all the calculated values
RetCells(1, 1) = a 'Slope
RetCells(1, 2) = b 'Intercept
RetCells(3, 1) = RR 'R^2
RetCells(3, 2) = SEy 's(y)
RetCells(4, 1) = SSR / SS 'F
RetCells(4, 2) = n - numVariables 'DegreeofFreedom = n - variables
RetCells(5, 1) = SSR
RetCells(5, 2) = SSE
returnFromFunction:
If (constB = False) Then RetCells(2, 2) = 0
LINEST2 = RetCells 'Populate the range(or array) with the final resulsts
Application.ScreenUpdating = True
End Function
Can this help me in what I attempting to achieve?
Bookmarks