Function QuadCoef(x As Range, y As Range, coef As String) As DoubleDim XArray1() As Double
Dim YArray1() As Double
Dim cyarray() As Variant
Dim cxarray() As Variant
Dim rMax As Integer
Dim crMax As Integer
rMax = x.Count
crMax = rMax - WorksheetFunction.CountBlank(x)
ReDim XArray1(1 To crMax, 1 To 3) As Double
ReDim YArray1(1 To crMax, 1 To 1) As Double
'set values to array
cxarray() = x.Value
cyarray() = y.Value
'fill y and x array
Dim i As Integer
Dim T As Integer
T = 1
For i = 1 To rMax
If IsNumeric(cxarray(i, 1)) = True And IsEmpty(cxarray(i, 1)) = False Then
XArray1(T, 2) = cxarray(i, 1)
YArray1(T, 1) = cyarray(i, 1)
T = T + 1
Else
T = T
End If
Next i
' Fill the first column of XArray1 with 1
For i = 1 To crMax
XArray1(i, 1) = 1
Next i
'' fill 3rd column with x^2 in x array
For i = 1 To crMax
XArray1(i, 3) = XArray1(i, 2) * XArray1(i, 2)
Next i
Dim j As Integer, m As Integer, N As Integer
Dim bArray, pArray, piArray
Dim qArray, xtArray
' Dimension the arrays:
ReDim xtArray(1 To 3, 1 To crMax) As Double
ReDim pArray(1 To 3, 1 To 3) As Double
ReDim piArray(1 To 3, 1 To 3) As Double
ReDim qArray(1 To 3, 1 To 1) As Double
ReDim bArray(1 To 3, 1 To 1) As Double
Call Transpose(XArray1, crMax, 3, xtArray)
Call Multiply(xtArray, 3, crMax, XArray1, 3, pArray)
Call Invert(pArray, 3, piArray)
Call Multiply(xtArray, 3, crMax, YArray1, 1, qArray)
Call Multiply(piArray, 3, 3, qArray, 1, bArray)
' Determines coefficient output
Select Case coef
Case "c", "C"
QuadCoef = bArray(1, 1)
Case "b", "B"
QuadCoef = bArray(2, 1)
Case "a", "A"
QuadCoef = bArray(3, 1)
Case Else
MsgBox " Select a,b, or c as coefficient)"
End Select
End Function
Sub Multiply(M1, r1, C1, M2, c2, MOut)
' Computes the product of two matrices: MOut = M1 times M2
' r1: number of rows in M1
' c1: number of columns in M1
' c2: number of columns in M2
' M2 must have c1 rows
' MOut will have r1 rows and c2 columns
Dim j As Integer
Dim i As Long, k As Long
For i = 1 To r1
For j = 1 To c2
MOut(i, j) = 0
For k = 1 To C1
MOut(i, j) = MOut(i, j) + M1(i, k) * M2(k, j)
Next k
Next j
Next i
End Sub
Sub Transpose(m, r, c, MT)
' Computes the transpose MT of matrix M
' r: number of rows in M
' c: number of columns in M
' MT will have c rows and r columns
Dim i As Long, j As Long
For i = 1 To c
For j = 1 To r
MT(i, j) = m(j, i)
Next j
Next i
End Sub
Sub Invert(m, nrc, MInv)
' The square input and output matrices are M and MInv
' respectively; nrc is the number of rows and columns in
' M and MInv
Dim i As Integer, icol As Integer, irow As Integer
Dim j As Integer, k As Integer, L As Integer, LL As Integer
Dim big As Double, dummy As Double
Dim N As Integer, pivinv As Double
Dim u As Double
N = nrc + 1
ReDim bb(1 To N, 1 To N) As Double
ReDim ipivot(1 To N) As Double
ReDim index(1 To N) As Double
ReDim indexr(1 To N) As Double
ReDim indexc(1 To N) As Double
u = 1
' Copy the input matrix in order to retain it
For i = 1 To nrc
For j = 1 To nrc
MInv(i, j) = m(i, j)
Next j
Next i
' The following is the Gauss-Jordan elimination routine
' GAUSSJ from J. C. Sprott, "Numerical Recipes: Routines
' and Examples in BASIC", Cambridge University Press,
' Copyright (C)1991 by Numerical Recipes Software. Used by
' permission. Use of this routine other than as an integral
' part of the present book requires an additional license
' from Numerical Recipes Software. Further distribution is
' prohibited. The routine has been modified to yield
' double-precision results.
For j = 1 To nrc
ipivot(j) = 0
Next j
For i = 1 To nrc
big = 0
For j = 1 To nrc
If ipivot(j) <> u Then
For k = 1 To nrc
If ipivot(k) = 0 Then
If Abs(MInv(j, k)) >= big Then
big = Abs(MInv(j, k))
irow = j
icol = k
End If
ElseIf ipivot(k) > 1 Then Exit Sub
End If
Next k
End If
Next j
ipivot(icol) = ipivot(icol) + 1
If irow <> icol Then
For L = 1 To nrc
dummy = MInv(irow, L)
MInv(irow, L) = MInv(icol, L)
MInv(icol, L) = dummy
Next L
For L = 1 To nrc
dummy = bb(irow, L)
bb(irow, L) = bb(icol, L)
bb(icol, L) = dummy
Next L
End If
indexr(i) = irow
indexc(i) = icol
If MInv(icol, icol) = 0 Then Exit Sub
pivinv = u / MInv(icol, icol)
MInv(icol, icol) = u
For L = 1 To nrc
MInv(icol, L) = MInv(icol, L) * pivinv
bb(icol, L) = bb(icol, L) * pivinv
Next L
For LL = 1 To nrc
If LL <> icol Then
dummy = MInv(LL, icol)
MInv(LL, icol) = 0
For L = 1 To nrc
MInv(LL, L) = MInv(LL, L) - MInv(icol, L) * dummy
bb(LL, L) = bb(LL, L) - bb(icol, L) * dummy
Next L
End If
Next LL
Next i
For L = nrc To 1 Step -1
If indexr(L) <> indexc(L) Then
For k = 1 To nrc
dummy = MInv(k, indexr(L))
MInv(k, indexr(L)) = MInv(k, indexc(L))
MInv(k, indexc(L)) = dummy
Next k
End If
Next L
Erase indexc, indexr, ipivot
End Sub
Function QuadCalc(a As Double, b As Double, c As Double, y As Double) As Double
QuadCalc = (-b + Sqr((b ^ 2) - (4 * a * (c - y)))) / (2 * a)
End Function
