Function ProctorMax(rH2O As Range, rRho As Range) As Variant
' shg 2018 on MrExcel.com
' UDF wrapper for avdProctorMax
' This code may be used for any purpose, private or commercial,
' provided this header remains intact.
Dim i As Long
Dim cell As Range
Dim adH2O() As Double
Dim adRho() As Double
If rH2O.Cells.CountLarge <> rRho.Cells.CountLarge Then
ProctorMax = Array("Unequal input size!", "")
ElseIf rH2O.Cells.CountLarge < 3 Then
ProctorMax = Array("Need at least three points!", "")
Else
ReDim adH2O(1 To rH2O.Cells.Count)
ReDim adRho(1 To UBound(adH2O))
On Error GoTo NonNum
For Each cell In rH2O.Cells
i = i + 1
adH2O(i) = cell.Value2
Next cell
i = 0
For Each cell In rRho.Cells
i = i + 1
adRho(i) = cell.Value2
Next cell
On Error GoTo RegErr
ProctorMax = avdProctorMax(adH2O, adRho)
Exit Function
End If
NonNum:
ProctorMax = Array("Not numeric:", cell.Address(False, False))
Exit Function
RegErr:
ProctorMax = Array("Regression error!", "")
Exit Function
End Function
Function avdProctorMax(adH2O() As Double, adRho() As Double) As Variant
' shg 2018
' VBA only
' Returns the calculated max for the regression of adRho on adH2O
' adH20 (moisture content) must be in ascending order
' If there are only three points, performs a 2nd-order regression
' if there are four or more points, performs third-order regression
' Returns an error if the max is not between the first and last values in adH2O
Dim H2O As Double
Dim Rho As Double
Dim avdCoeff As Variant
With Application
If UBound(adH2O) < 3 Then
' do a 2nd order regression
' linear coefficients of derivative
Dim m As Double
Dim b As Double
avdCoeff = .LinEst(adRho, .Power(adRho, Array(1, 2)))
m = 2# * avdCoeff(1)
b = 1# * avdCoeff(2)
H2O = -b / m
If H2O < adH2O(1) Or H2O > adH2O(UBound(adH2O)) Then
Err.Raise 513
Exit Function
Else
Rho = avdCoeff(1) * H2O ^ 2# + avdCoeff(2) * H2O + avdCoeff(3)
avdProctorMax = Array(H2O, Rho)
End If
Else
' do a 3rd order regression
' quadratic coefficients of derivative
Dim aa As Double
Dim bb As Double
Dim cc As Double
Dim dd As Double ' quadratic determinant
Dim v
v = .Power(adRho, .Transpose(Array(1#, 2#, 3#)))
avdCoeff = .LinEst(adRho, .Power(adH2O, .Transpose(Array(1#, 2#, 3#))))
aa = 3# * avdCoeff(1)
bb = 2# * avdCoeff(2)
cc = 1# * avdCoeff(3)
dd = bb ^ 2 - 4 * aa * cc
If dd < 0# Then
Err.Raise 513
Exit Function
Else
H2O = (-bb + Sqr(dd)) / (2# * aa)
If H2O < adH2O(1) Or H2O > adH2O(UBound(adH2O)) Then
H2O = (-bb - Sqr(dd)) / (2# * aa)
If H2O < adH2O(1) Or H2O > adH2O(UBound(adH2O)) Then
Err.Raise 513
Exit Function
End If
End If
Rho = avdCoeff(1) * H2O ^ 3# + _
avdCoeff(2) * H2O ^ 2# + _
avdCoeff(3) * H2O + _
avdCoeff(4)
avdProctorMax = Array(H2O, Rho)
End If
End If
End With
End Function
Function ProctorMax(rH2O As Range, rRho As Range) As Variant
' shg 2018 on MrExcel.com
' UDF wrapper for avdProctorMax
' This code may be used for any purpose, private or commercial,
' provided this header remains intact.
Dim i As Long
Dim cell As Range
Dim adH2O() As Double
Dim adRho() As Double
If rH2O.Cells.CountLarge <> rRho.Cells.CountLarge Then
ProctorMax = Array("Unequal input size!", "")
ElseIf rH2O.Cells.CountLarge < 3 Then
ProctorMax = Array("Need at least three points!", "")
Else
ReDim adH2O(1 To rH2O.Cells.Count)
ReDim adRho(1 To UBound(adH2O))
On Error GoTo NonNum
For Each cell In rH2O.Cells
i = i + 1
adH2O(i) = cell.Value2
Next cell
i = 0
For Each cell In rRho.Cells
i = i + 1
adRho(i) = cell.Value2
Next cell
On Error GoTo RegErr
ProctorMax = avdProctorMax(adH2O, adRho)
Exit Function
End If
NonNum:
ProctorMax = Array("Not numeric:", cell.Address(False, False))
Exit Function
RegErr:
ProctorMax = Array("Regression error!", "")
Exit Function
End Function
Function avdProctorMax(adH2O() As Double, adRho() As Double) As Variant
' shg 2018
' VBA only
' Returns the calculated max for the regression of adRho on adH2O
' adH20 (moisture content) must be in ascending order
' If there are only three points, performs a 2nd-order regression
' if there are four or more points, performs third-order regression
' Returns an error if the max is not between the first and last values in adH2O
Dim H2O As Double
Dim Rho As Double
Dim avdCoeff As Variant
With Application
If UBound(adH2O) < 3 Then
Err.Raise 513
Exit Function
ElseIf UBound(adH2O) = 3 Then
' do a 2nd order regression
' linear coefficients of derivative
Dim m As Double
Dim b As Double
avdCoeff = .LinEst(adRho, .Power(adH2O, .Transpose(Array(1#, 2#))))
m = 2# * avdCoeff(1)
b = 1# * avdCoeff(2)
H2O = -b / m
If H2O < adH2O(1) Or H2O > adH2O(UBound(adH2O)) Then
Err.Raise 513
Exit Function
Else
Rho = avdCoeff(1) * H2O ^ 2# + _
avdCoeff(2) * H2O + _
avdCoeff(3)
avdProctorMax = Array(H2O, Rho)
End If
Else
' do a 3rd order regression
' quadratic coefficients of derivative
Dim aa As Double
Dim bb As Double
Dim cc As Double
Dim dd As Double ' quadratic determinant
Dim v
v = .Power(adRho, .Transpose(Array(1#, 2#, 3#)))
avdCoeff = .LinEst(adRho, .Power(adH2O, .Transpose(Array(1#, 2#, 3#))))
aa = 3# * avdCoeff(1)
bb = 2# * avdCoeff(2)
cc = 1# * avdCoeff(3)
dd = bb ^ 2# - 4# * aa * cc
If dd < 0# Then
Err.Raise 513
Exit Function
Else
H2O = (-bb + Sqr(dd)) / (2# * aa)
If H2O < adH2O(1) Or H2O > adH2O(UBound(adH2O)) Then
H2O = (-bb - Sqr(dd)) / (2# * aa)
If H2O < adH2O(1) Or H2O > adH2O(UBound(adH2O)) Then
Err.Raise 513
Exit Function
End If
End If
Rho = avdCoeff(1) * H2O ^ 3# + _
avdCoeff(2) * H2O ^ 2# + _
avdCoeff(3) * H2O + _
avdCoeff(4)
avdProctorMax = Array(H2O, Rho)
End If
End If
End With
End Function
