Hello,
I'm trying to extract the coefficients from the text box created when doing a trendline on an excel chart.
I've attempted 2 solutions from this forum, neither of which I can get to work.
(a) I've tried Dave Braden's VBA
code that creates function TLcoef, but it returns a "value" error. I believe I've fixed the word wrap issues, but
I'm not a VBA programmer, so can't be sure. I've also tried entering it as an array formula, to no avail. I've pasted
Dave's code at bottom of this post.
(b) I've also tried Tom Ogilvy's macro solution. this "almost"
works. the problem is that my equation has a negative coefficient, and his code does not account for negative's, only
positives. I've modified the code slightly, so that the negative coefficient is listed in the spreadsheet, but I can't
figure out how to preserve / display this value as a negative. in other words, all the coefficients are assumed positive.
the code mod I made is to simply add the line :
sFormula = Application.Substitute(sFormula, " - ",
",")
Any help would be appreciated.
Thank You,
=========================================
Const cFirstNumPos = 5 ' pos. of first integer in displayed eqn
Const cMaxFormat = "0.00000000000000E+00"
Function TLcoef(vSheet, vCht, vSeries, vTL)
'Return
coefficients of an Excel chart trendline, *to precision displayed*
'
'Note: While Trendline seemingly always reports subsequent terms from
'a given one on, sometimes it reduces the order of the fit. So this function
'returns, for a poly-fit, an array of length 1 + the order of the requested fit,
' *not* the number of values displayed. The last value in the return array
'is the constant term; preceeding values correspond to higher-order x.
Dim o As Trendline
Application.Volatile
If ParamErr(TLcoef, vSheet, vCht, vSeries, vTL) Then Exit Function
On Error GoTo HanErr
Set o = Sheets(vSheet).ChartObjects(vCht).Chart.SeriesCollection(vSeries).Trendlines(vTL)
TLcoef = ExtractCoef(o, cFirstNumPos)
Exit Function
HanErr:
TLcoef = CVErr(xlErrValue)
End Function
Function TLeval(vX, vSheet, vCht, vSeries, vTL)
'DJ Braden
' Exp/logs are done for cases xlPower and xlExponential to allow
' for greater range of arguments.
Dim o As Trendline, vRet
Application.Volatile
' If Not CheckNum(vX, TLeval) Then Exit Function
If ParamErr(TLeval, vSheet, vCht, vSeries, vTL) Then Exit Function
Set o =
Sheets(vSheet).ChartObjects(vCht).Chart.SeriesCollection(vSe*ries).Trendlines(vTL)
vRet = ExtractCoef(o,
cFirstNumPos)
Select Case o.Type
Case xlLinear
vRet(1) = vX * vRet(1) + vRet(2)
Case xlExponential 'see comment above
vRet(1) = Exp(Log(vRet(1)) + vX * vRet(2))
Case xlLogarithmic
vRet(1) = vRet(1) * Log(vX) + vRet(2)
Case xlPower 'see comment above
vRet(1) = Exp(Log(vRet(1)) + Log(vX) * vRet(2))
Case xlPolynomial
Dim l As Long
vRet(1) = vRet(1) * vX + vRet(2)
For l = 3 To UBound(vRet)
vRet(1) = vX * vRet(1) + vRet(l)
Next
End Select
TLeval = vRet(1)
Exit Function
HanErr:
TLeval = CVErr(xlErrValue)
End Function
Private Function ExtractCoef(o As Trendline, ByVal lLastPos As Long)
Dim lCurPos As Long, s As String
s = o.DataLabel.Text
If o.DisplayRSquared Then
lCurPos = InStr(s, "R")
s = Left$(s, lCurPos - 1)
End If
If o.Type <> xlPolynomial Then
ReDim v(1 To 2) As Double
If o.Type = xlExponential Then
s = Application.WorksheetFunction.Substitute(s, "x", "")
s = Application.WorksheetFunction.Substitute(s, "e", "x")
ElseIf o.Type = xlLogarithmic Then
s = Application.WorksheetFunction.Substitute(s, "Ln(x)", "x")
End If
lCurPos = InStr(1, s, "x")
If lCurPos = 0 Then
v(2) = Mid(s, lLastPos)
Else
v(1) = Mid(s, lLastPos, lCurPos - lLastPos)
v(2) = Mid(s, lCurPos + 1)
End If
Else 'have a polynomial
Dim lOrd As Long
ReDim v(1 To o.Order + 1) As Double
lCurPos = InStr(s, "x")
If lCurPos = 0 Then
v(o.Order + 1) = Mid(s, lLastPos)
Exit Function 'with single constant term
End If
'else
lOrd = Mid(s, lCurPos + 1, 1)
Do While lOrd > 1
v(UBound(v) - lOrd) = Mid(s, lLastPos, lCurPos - lLastPos)
lLastPos = lCurPos + 2
lCurPos = InStr(lLastPos, s, "x")
lOrd = lOrd - 1
Loop
'peel off coeffs. for affine terms in eqn
v(o.Order) = Mid(s, lLastPos, lCurPos - lLastPos)
v(o.Order + 1) = Mid(s, lCurPos + 1)
End If
ExtractCoef = v
End Function
Private Function ParamErr(v, ParamArray parms())
Dim l As Long
For l = LBound(parms) To UBound(parms)
If VarType(parms(l)) = vbError Then
v = parms(l)
ParamErr = True
Exit Function
End If
Next
End Function
=========================================