Function AreaFit(Optional xRng As Range, Optional yRng As Range, Optional iFitType As Integer, Optional iReturn As Integer = 1, Optional iSummaryBox As Integer = 1) As Double
' PA HS Teacher () 6-16-05
' This function numerically approximates the Area Under the Curve and Calculates Fit Lines for Data
' AUC is calculated using Simpson's, Trapezoid, Left, and Right Rules
' Fits are calculated for Linear, Exponential, (Natrual Logrithmic), and Power Fits
' See comments at the bottom for a brief Summary
' Fit Calculations based on http://mathworld.wolfram.com/LeastSquaresFittingExponential.html
' (PA HS Teacher)
'
'
On Error GoTo ErrHandler
If xRng Is Nothing Then GoTo ErrHandler
'********* Declaration of Variables and Arrays *********************
Dim N As Integer, yRows As Integer
Dim xRow As Integer, yRow As Integer
Dim XAvg As Double, YAvg As Double, XStdev As Double, YStdev As Double, R2 As Double
Dim SigmaX As Double, SigmaY As Double, SigmaX2 As Double, SigmaY2 As Double
Dim SigmaLnX As Double, SigmaLnY As Double, SigmaXLnY As Double, SigmaX2Y As Double
Dim SigmaYLnY As Double, SigmaXY As Double, SigmaXYLnY As Double, SigmaLnXLnY As Double
Dim SigmaLnX2 As Double, SigmaYLnX As Double, SigmaZXZY As Double
Dim LnXArr() As Double, LnYArr() As Double, XLnYArr() As Double, X2YArr() As Double, LnXLnY As Double
Dim XArr() As Double, YArr() As Double, X2Arr() As Double, Y2Arr() As Double, LnXLnYArr() As Double
Dim YLnYArr() As Double, XYArr() As Double, XYLnYArr() As Double, LnX2Arr() As Double
Dim YLnXArr() As Double, ZXZYArr() As Double, SSXX As Double, SSYY As Double, SSXY As Double
Dim A As Double, B As Double, A1 As Double, A2 As Double, A3 As Double, A4 As Double
Dim SimpsonsRule As Double, TrapezoidRule As Double, B1 As Double, B2 As Double, B3 As Double, B4 As Double
Dim RightRule As Double, LeftRule As Double, h As Double, AUC As Double, S As String, EX As String
On Error GoTo ErrHandler
If xRng Is Nothing Then GoTo ErrHandler
If xRng.Rows.Count > 2 Then N = xRng.Rows.Count
If xRng.Rows.Count < 3 Then N = xRng.Columns.Count
ReDim XArr(1 To N)
ReDim YArr(1 To N)
ReDim X2Arr(1 To N)
ReDim Y2Arr(1 To N)
ReDim LnXArr(1 To N)
ReDim LnYArr(1 To N)
ReDim XLnYArr(1 To N) 'Arrays are (Dimensionalized?)
ReDim X2YArr(1 To N) 'Declared as N row x 1 column arrays
ReDim YLnYArr(1 To N)
ReDim XYArr(1 To N)
ReDim XYLnYArr(1 To N)
ReDim LnXLnYArr(1 To N)
ReDim LnX2Arr(1 To N)
ReDim YLnXArr(1 To N)
ReDim ZXZYArr(1 To N)
'********* Data is pulled into X and Y Arrays ***************
For i = 1 To N
'****** If the YRange is ommitted ***************************
If yRng Is Nothing Then
If xRng.Rows.Count = N Then 'If Data is Aligned Vertically
XArr(i) = xRng.Cells(i, 1) 'X Data is the First Column of the Range in the First Parameter
If xRng.Columns.Count > 1 Then YArr(i) = xRng.Cells(i, 2) 'Y Data is the 2nd column of Xrange (if a 2nd column exists)
If xRng.Columns.Count = 1 Then YArr(i) = i 'Otherwise Y data is simply {1;2;3;...;N}
End If
If xRng.Columns.Count = N Then 'If Data is Aligned Horizontally
XArr(i) = xRng.Cells(1, i) 'X Data is the First Row of the Range in the First Parameter
If xRng.Rows.Count > 1 Then YArr(i) = xRng.Cells(2, i) 'Y Data is the 2nd row of Xrange (if it exists)
If xRng.Rows.Count = 1 Then YArr(i) = i 'Otherwise Y data is simply {1;2;3;...;N}
End If
'****** If the YRange is included ***************************
Else
If xRng.Rows.Count = N Then 'If Data is Aligned Vertically
XArr(i) = xRng.Cells(i, 1)
YArr(i) = yRng.Cells(i, 1)
Else 'If Data is Aligned Horizontally
XArr(i) = xRng.Cells(1, i)
YArr(i) = yRng.Cells(1, i)
End If
End If
Next i
XAvg = Application.WorksheetFunction.Average(XArr()) 'X and Y Averages and
YAvg = Application.WorksheetFunction.Average(YArr()) 'Standard Deviations
XStdev = Application.WorksheetFunction.StDev(XArr()) 'Needed for some Calculations below
YStdev = Application.WorksheetFunction.StDev(YArr())
'***** Arryas and Summmations Used for Later Calculations ****
For i = 1 To N
X2Arr(i) = XArr(i) ^ 2
Y2Arr(i) = YArr(i) ^ 2
If XArr(i) >= 1 Then LnXArr(i) = Log(XArr(i)) 'If allows only Ln(x) for x>=1
If YArr(i) >= 1 Then LnYArr(i) = Log(YArr(i))
XLnYArr(i) = XLnYArr(i) + XArr(i) * LnYArr(i)
X2YArr(i) = X2Arr(i) * YArr(i)
YLnYArr(i) = YArr(i) * LnYArr(i)
XYArr(i) = XArr(i) * YArr(i)
XYLnYArr(i) = XYArr(i) * LnYArr(i)
LnXLnYArr(i) = LnXArr(i) * LnYArr(i)
LnX2Arr(i) = LnXArr(i) ^ 2
YLnXArr(i) = YArr(i) * LnXArr(i)
ZXZYArr(i) = ((XArr(i) - XAvg) / XStdev) * ((YArr(i) - YAvg) / YStdev)
SigmaX = SigmaX + XArr(i)
SigmaY = SigmaY + YArr(i)
SigmaX2 = SigmaX2 + X2Arr(i)
SigmaY2 = SigmaY2 + Y2Arr(i)
SigmaLnX = SigmaLnX + LnXArr(i)
SigmaLnY = SigmaLnY + LnYArr(i)
SigmaXLnY = SigmaXLnY + XLnYArr(i)
SigmaX2Y = SigmaX2Y + X2YArr(i)
SigmaYLnY = SigmaYLnY + YLnYArr(i)
SigmaXY = SigmaXY + XYArr(i)
SigmaXYLnY = SigmaXYLnY + XYLnYArr(i)
SigmaLnXLnY = SigmaLnXLnY + LnXLnYArr(i)
SigmaLnX2 = SigmaLnX2 + LnX2Arr(i)
SigmaYLnX = SigmaYLnX + YLnXArr(i)
SigmaZXZY = SigmaZXZY + ZXZYArr(i)
SSXX = SSXX + (XArr(i) - XAvg) ^ 2
SSYY = SSYY + (YArr(i) - YAvg) ^ 2
SSXY = SSXY + (XArr(i) - XAvg) * (YArr(i) - YAvg)
Next i
' ******** Numerical Approximation of Area Under Curve ***********
' Numerical integration: Simpson's Rule, LeftRule, RightRule, TrapezoidRule
' Simpson's Rule base on: S = (h/3)*(Y0 + 4Y1 + 2Y2 + 4Y3 + ... + 2Yn-2 + 4Yn-1 + Yn)
For i = 2 To N - 1
h = (XArr(i + 1) - XArr(i - 1)) * 0.5 ' Horizontal distant between adjacent X's
If i Mod 2 = 0 Then SimpsonsRule = SimpsonsRule + 4 * YArr(i) * h / 3
If i Mod 2 = 1 Then SimpsonsRule = SimpsonsRule + 2 * YArr(i) * h / 3
Next i
SimpsonsRule = SimpsonsRule + (YArr(1) + YArr(N)) * (h / 3)
' Right Rule, Left Rule and Trapezoid Rule
For i = 2 To N
RightRule = RightRule + YArr(i) * (XArr(i) - XArr(i - 1))
LeftRule = LeftRule + YArr(i - 1) * (XArr(i) - XArr(i - 1))
TrapezoidRule = (LeftRule + RightRule) / 2
Next i
' ********* Calculation of Fit Equations *************************
' Linear Fit:(1) Linear Fit Where Y = Ax + B
' Also check out Excel's built in Linest Function (it can provide a number of additional stats)
A1 = (YAvg * SigmaX2 - XAvg * SigmaXY) / (SigmaX2 - N * XAvg ^ 2)
B1 = (SigmaXY - N * XAvg * YAvg) / (SigmaX2 - N * XAvg ^ 2)
R2 = SSXY ^ 2 / (SSXX * SSYY)
r = R2 ^ 0.5
' Exponential Fit:(2) Calculation of exponential fit where Y = Ae^(Bx)
A2 = Exp((SigmaX2Y * SigmaYLnY - SigmaXY * SigmaXYLnY) / (SigmaY * SigmaX2Y - SigmaXY ^ 2))
B2 = (SigmaY * SigmaXYLnY - SigmaXY * SigmaYLnY) / (SigmaY * SigmaX2Y - SigmaXY ^ 2)
' Natural Log Fit:(3) Calculation of (natural)Logarithmic Fit where Y = A + BLnX
B3 = (N * SigmaYLnX - SigmaY * SigmaLnX) / (N * SigmaLnX2 - SigmaLnX ^ 2)
A3 = (SigmaY - B * SigmaLnX) / N
' Power Fit:(4) Calculation of Power Fit where Y = Ax^B
B4 = (N * SigmaLnXLnY - SigmaLnX * SigmaLnY) / (N * SigmaLnX2 - SigmaLnX ^ 2)
A4 = Exp((SigmaLnY - B * SigmaLnX) / N)
' ***** Determination of Value to Be returned.
Select Case iFitType
Case 0
Select Case iReturn
Case 1: AreaFit = SimpsonsRule
Case 2: AreaFit = TrapezoidRule
Case 3: AreaFit = LeftRule
Case 4: AreaFit = RightRule
End Select
Case 1
If iReturn = 1 Then AreaFit = A1
If iReturn = 2 Then AreaFit = B1
If iReturn = 3 Then AreaFit = R2
If iReturn = 4 Then AreaFit = r
Case 2
If iReturn = 1 Then AreaFit = A2
If iReturn = 2 Then AreaFit = B2
Case 3
If iReturn = 1 Then AreaFit = A3
If iReturn = 2 Then AreaFit = B3
Case 4
If iReturn = 1 Then AreaFit = A4
If iReturn = 2 Then AreaFit = B4
End Select
S = S & Format(SimpsonsRule, "0.0000") & " Simpson's Rule for Area Under the Curve" & " (xrng,yrng,0,1,1)" & Chr(10)
S = S & Format(TrapezoidRule, "0.0000") & " Trapezoid Rule for Area Under the Curve" & " (xrng,yrng,0,2,1)" & Chr(10)
S = S & Format(LeftRule, "0.0000") & " Left Rule for Area Under the Curve" & " (xrng,yrng,0,3,1)" & Chr(10)
S = S & Format(RightRule, "0.0000") & " Right Rule for Area Under the Curve" & " (xrng,yrng,0,4,1)" & Chr(10)
S = S & Format(A1, "0.0000") & " A:Linear Fit, of Y = AX + B (xrng,yrng,1,1,1)" & Chr(10)
S = S & Format(B1, "0.0000") & " B:Linear Fit, Y = " & Format(A1, "0.0000") & " X + " & Format(B1, "0.0000") & " (xrng,yrng,1,2,1)" & Chr(10)
S = S & Format(R2, "0.0000") & " R^2: Linear Fit, " & Format(r, "0.0000") & " R (Pearson) " & " (xrng,yrng,1,3,1)" & Chr(10)
S = S & Format(A2, "0.0000") & " A for Exponential Fit, of Y = A e^BX" & " (xrng,yrng,2,1,1)" & Chr(10)
S = S & Format(B2, "0.0000") & " B for Exponential Fit, " & " Y = " & Format(A2, "0.0000") & " e^" & Format(B2, "0.0000") & "X" & " (xrng,yrng,2,2,1)" & Chr(10)
S = S & Format(A3, "0.0000") & " A for Natural Log Fit, of Y = A + BLn(X) (xrng,yrng,3,1,1)" & Chr(10)
S = S & Format(B3, "0.0000") & " B for Natural Log Fit, Y = " & Format(A3, "0.0000") & " Ln(" & Format(B3, "0.0000") & "X)" & " (xrng,yrng,3,2,1)" & Chr(10)
S = S & Format(A4, "0.0000") & " A for Power Fit, of Y = AX^B (xrng,yrng,4,1,1)" & Chr(10)
S = S & Format(B4, "0.0000") & " B for Power Fit, " & "Y = " & Format(A4, "0.0000") & " X^" & Format(B4, "0.0000") '& " (xrng,yrng,4,2,1)" & Chr(10)
S = S & "N = " & N & Chr(10)
S = S & "X: Average: " & Format(XAvg, "0.0000") & " Standard Deviation: " & Format(XStdev, "0.0000") & Chr(10)
S = S & "Y: Average: " & Format(YAvg, "0.0000") & " Standard Deviation: " & Format(YStdev, "0.0000") & Chr(10)
If iSummaryBox = 1 Then
Dummy = MsgBox(S, , "Summary: (To turn off make last parameter 0. e.g. (xrng,yrng,3,2,0))")
End If
Exit Function
ErrHandler:
S = "Whoops, You made a mistake in using this function in Cell " & Application.Caller.Address & Chr(10) & Chr(10)
S = S & "AreaFit(xRng, yrng(optional), iFitType(optional), iReturn(optional), iSummmaryBox(optional))" & Chr(10) & Chr(10)
S = S & "xRng, The Range of Cells Containing your X data" & Chr(10) & Chr(10)
S = S & "yRng, The Range of Cells Containing your Y data. If ommitted, the Y data is assumed to be the 2nd Colum (or Row) of xRng" & Chr(10) & Chr(10)
S = S & "iFitType, specifies which family of calculation you would like to calculate. 0 for Area Under the Curve, 1 for a Linear Fit, 2 for an exponential fit etc." & Chr(10) & Chr(10)
S = S & "iReturn, specifies which number within the family you'd like to return. For example and iFit of 1 returns a Simpson's Rule for AUC calculations, or the constant A for fits" & Chr(10) & Chr(10)
S = S & "iSummaryBox, If you would like a summry message box of all calculations, make this 1." & Chr(10) & Chr(10)
S = S & "Would you like to see some examples?"
Dummy = MsgBox(S, vbYesNo, Application.Caller.Address & " is returning an error")
If Dummy = vbYes Then
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 0, 1,0) Area under Curve as calculated by Simpson's Rule"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 0, 2,0) Area under Curve as calculated by Trapezoid Rule"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 0, 3,0) Area under Curve as calculated by Left Rule"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 0, 4,0) Area under Curve as calculated by Right Rule"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 1, 1,0) Linear Fit, A of Y = Ax + B"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 1, 2,0) Linear Fit, B of Y = Ax + B"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 1, 3,0) Linear Fit, R^2 for linear fit"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 1, 4,0) Linear Fit, R for linear fit (Pearson)"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 2, 1,0) Exponential Fit, A of Y = Ae^(Bx)"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 2, 2,0) Exponential Fit, B of Y = Ae^(Bx)"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 3, 1,0) (Natural)Log Fit, A of Y = A + BLnX"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 3, 2,0) (Natural)Log Fit, B of Y = A + BLnX"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 4, 1,0) Power Fit, A of Y = Ax^B"
EX = EX & Chr(10) & "AreaFit(XRange,YRange, 4, 2,0) Power Fit, B of Y = Ax^B"
Dummy = MsgBox(EX, vbYesNo, "Would you like further explanation?")
If Dummy = vbYes Then
EX = "****** A Note About Optional Parameters ************************"
EX = EX & Chr(10) & "The 2nd, 3rd, 4th and 5th arguments YRng, iFit, iReturn, and iSummaryBox are optional" & Chr(10)
EX = EX & Chr(10) & "iFit defaults to 0, Calcluating Area Under the Curve by default" & Chr(10)
EX = EX & "iReturn defaults to 1" & Chr(10)
EX = EX & "iSummaryBox defaults to 0" & Chr(10)
EX = EX & Chr(10) & "If you would like a summary box of all AUC calculations and Curve fits, make this 1)" & Chr(10)
EX = EX & Chr(10) & "YArr() defaults to {1;2;3;...;N} if Xrng is 1 x N."
EX = EX & Chr(10) & "YArr() defaults to the 2nd column or Row of XRng if Xrng ix 2 x N or greater"
Dummy = MsgBox(EX, vbYesNo, "Would you like to see more examples?")
If Dummy = vbYes Then
EX = "Example: AreaFit(XRange, YRange) Area under Curve as calculated by Simpson's Rule"
EX = EX & Chr(10) & "Example: AreaFit(XRange, YRange,,3) Area under Curve as calculated by Left Rule"
EX = EX & Chr(10) & "Example: AreaFit(XRange, YRange,2) Exponential Fit, A of Y = Ae^(Bx)"
EX = EX & Chr(10) & "Example: AreaFit(XRange) A of Y = Ax + B, where XArr() = {1;2;3;...;N}"
EX = EX & Chr(10) & "Example: AreaFit(A1:B10) Area under Curve Simpsons (Xrng = A1:A10, Yrng = B1:B10)"
EX = EX & Chr(10) & "Example: AreaFit(A1:A10,,1,1) Slope of Linear Fit Line A1:A10 vs. {1;2;3;...;10}"
EX = EX & Chr(10) & "Example: AreaFit(A1:A10,B1:B10,0,1,1) will return Simpsons, but also a Summary Box will pop up."
EX = EX & Chr(10) & Chr(10) & "To see the actual code, press alt + F11 to bring p the VBA Editor" & Chr(10)
EX = EX & Chr(10) & "Find this workbook on the VBA Project List on the left, find Modules, Module 2" & Chr(10)
EX = EX & Chr(10) & "If you have questions you can e-mail me: "
Dummy = MsgBox(EX, vbOKOnly, "Questions: e-mail ")
End If
End If
End If
Exit Function
End Function
