Code Post: Trendline/Regression Routines

[David J. Braden]

Sorry for the length of this, but this is some very useful code to help with
regressions and determining Trendlines in charts. I wrote this today in reponse
to several posted and private requests.

I hope it's useful.
Regards to all, Dave Braden
===============

'These routines are designed to return an equation for a chart series' Trendline,
'or to get the equation of what a Trendline would be for a given series.

'Written 1999.7.22, DJ Braden

'Easiest way to see what's going on is to run TestIt and TestIt2, below.

'If you want the coefficients directly, call Regress. The
'order of the parameters follows the Excel LINEST and Trendline convention.

'Known defficiency: Doesn't handle the Moving Average. That is by design, as this
'is geared to getting regession equations.

Option Explicit
Option Base 1

Type TrendLineRec
Type As Long
'xlLinear= -4132 , xlLogarithmic = -4133, xlPolynomial=3,
'xlPower=4, xlExponential = 5, xlMovingAvg = 6
Order As Long
'The degree of a polynomial fit. Must be >=2. Excel limits this to 6,
'but you can go higher with these routines (not recommended, though)
Period As Long
'Used for Moving Averages; must be >= 2
InterceptIsAuto As Boolean
'True if no constant intercept defined in Options tab, else False
Intercept As Double
End Type

Sub TestIt1()
'How to use:
' Open a workbook and make an XY-chart (scatterplot).
' Don't worry about making a trendline: this will do a fit for you

Dim s As Series, v, x, TL As TrendLineRec

Set s = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
TL.Type = xlPolynomial
TL.Order = 4
TL.InterceptIsAuto = True

v = TrendLineEqn(s, TL)
If IsError(v) Then
MsgBox "Oops"
Else
x = InputBox("The equation is " & v & vbCr & vbCr & _
"Enter the x to evaluate it at:", "Howdy")
If x = "" Then Exit Sub
v = Application.WorksheetFunction.Substitute(v, "x", x)
v = Application.Evaluate(v)
If IsError(v) Then
MsgBox "Bad evaluation point"
Else
MsgBox "f(x) = " & v
End If
End If
End Sub

Sub TestIt2()
'How to use:
' Use the chart from you made, and add your own trendline,
' (except Moving Average), click on the
' Options tab, and check Display Equation on Chart. Then run this sub.

Dim s As Series, v, x
Dim TL As TrendLineRec

Set s = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
With s.Trendlines(1)
TL.Type = .Type
TL.Order = .Order
TL.InterceptIsAuto = .InterceptIsAuto
TL.Intercept = .Intercept
End With

v = TrendLineEqn(s, TL)
If IsError(v) Then
MsgBox "Oops"
Else
x = InputBox("The equation is " & v & vbCr & vbCr & _
"Enter the x to evaluate it at:", "Howdy")
If x = "" Then Exit Sub
v = Application.WorksheetFunction.Substitute(v, "x", x)
v = Application.Evaluate(v)
If IsError(v) Then
MsgBox "Bad evaluation point"
Else
MsgBox "f(x) = " & v
End If
End If
End Sub

Public Function TrendLineEqn(s As Series, TL As TrendLineRec) As Variant
'Will call Regress to get the coefficients, and then build up a string
'that can be run through Evaluate

Dim v As Variant, str As String

v = Regress(s, TL)
If IsError(v) Then TrendLineEqn = v: Exit Function

Select Case TL.Type
Case xlLinear
str = v(1) & "*x"
If v(2) <> 0 Then _
str = str & " " & Sign(v(2)) & " " & Abs(v(2))
Case xlPolynomial
Dim i As Integer, iO As Integer
iO = TL.Order
str = v(1) & "*(x^" & iO & ")"
For i = 2 To iO - 1
If v(i) <> 0 Then
str = str & " " & Sign(v(i)) & " " & Abs(v(i)) & "*x^" & iO + 1
- i
End If
Next
If v(iO) <> 0 Then
str = str & " " & Sign(v(iO)) & " " & Abs(v(iO)) & "*x"
End If
If v(iO + 1) <> 0 Then
str = str & " " & Sign(v(iO + 1)) & " " & Abs(v(iO + 1))
End If
Case xlExponential
str = v(2) & "*Exp(" & v(1) & ")"
Case xlLogarithmic
str = v(1) & "* Ln(x) " & Sign(v(2)) & Abs(v(2))
Case xlPower
str = v(2) & " * x^" & v(1)
Case xlMovingAvg
'Not implemented yet.
End Select
TrendLineEqn = str
End Function

Public Function Regress(s As Series, TL As TrendLineRec) As Variant
Dim var As Variant

On Error GoTo BugOut
If TL.InterceptIsAuto Then
Select Case TL.Type
Case xlLinear
Regress = Application.WorksheetFunction.LinEst(s.Values, s.XValues)
Case xlPolynomial
Dim str As String, i As Integer, varX As Variant
str = "^{1": For i = 2 To TL.Order: str = str & "," & i: Next: str =
str & "}"
varX = Application.Evaluate(ParseXRange(s.Formula) & str)
With Application.WorksheetFunction
Regress = .LinEst(.Transpose(s.Values), varX)
End With
Case xlExponential
var = Application.WorksheetFunction.LinEst(LnArray(s.Values), s.XValues)
var(2) = Exp(var(2))
Regress = var
Case xlLogarithmic
Regress = Application.WorksheetFunction.LinEst(s.Values, LnArray(s.XValues))
Case xlPower
var = Application.WorksheetFunction.LinEst(LnArray(s.Values), LnArray(s.XValues))
var(2) = Exp(var(2))
Regress = var
Case xlMovingAvg
'not implemented
Regress = CVErr(xlErrValue)
End Select
Else
Regress = RegressC(s, TL)
End If
Exit Function

BugOut:
Regress = CVErr(xlErrNum)
End Function

Private Function RegressC(s As Series, TL As TrendLineRec) As Variant
'Handles all Trendline functions that are specified with the optional constant active
Dim var, dblA As Double

On Error GoTo BugOut
dblA = TL.Intercept
Select Case TL.Type
Case xlLinear
With Application.WorksheetFunction
RegressC = Array((.SumProduct(s.XValues, s.Values) _
- dblA * .Sum(s.XValues)) _
/ .SumProduct(s.XValues, s.XValues), dblA)
End With
Case xlPolynomial
Dim str As String, i As Integer, xx, xy

str = "^{1": For i = 2 To TL.Order: str = str & "," & i: Next: str = str & "}"
With Application
xx = .Evaluate(ParseXRange(s.Formula) & str)
xy = .MMult(.Transpose(xx), .Transpose(s.Values))
For i = 1 To TL.Order
xy(i, 1) = xy(i, 1) - dblA * .Sum(.Index(xx, 0, i))
Next
xx = .MMult(.MInverse(.MMult(.Transpose(xx), xx)), xy)
ReDim var(1 To TL.Order + 1)
var(TL.Order + 1) = dblA
For i = 1 To TL.Order
var(i) = xx(TL.Order + 1 - i, 1)
Next
End With
RegressC = var
Case xlExponential
With Application.WorksheetFunction
var = Array((.SumProduct(s.XValues, LnArray(s.Values)) _
- Log(dblA) * .Sum(s.XValues)) _
/ .SumProduct(s.XValues, s.XValues), dblA)
End With
var(1) = dblA
RegressC = var
Case Else
'really shouldn't get here; the other Trends cannot have a constant
RegressC = CVErr(xlErrValue)
End Select
Exit Function

BugOut:
RegressC = CVErr(xlErrNum)
End Function

Private Function LnArray(arr) As Variant
LnArray = Application.Ln(arr)
End Function

Private Function ParseXRange(str As String) As String
Dim i As Integer
i = InStr(8, str, ",") + 1
ParseXRange = Mid$(str, i, InStr(i, str, ",") - i)
End Function

Private Function Sign(x As Variant) As String
Select Case x
Case Is > 0
Sign = "+"
Case Is < 0
Sign = "-"
Case Else
Sign = ""
End Select
End Function