Apex of a bell curve

J

jondavis1987

Active Member
Joined
Dec 31, 2015
Messages
443
Office Version
  1. 2019
Platform
  1. Windows
I have a scatter chart with smooth lines that creates a bell curve. Is there a formula i can make based off of the data to calculate the apex of the bell curve or is there an excel function to show the apex number and label it?
 
Sort by date Sort by votes

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
I thought this was an interesting enough problem to create a user-defined function:

B​
C​
D​
2​
Moisture​
Dry Density​
3​
13.8​
102.2​
4​
15.0​
107.6​
5​
16.4​
108.7​
6​
18.5​
103.6​
7​
8​
Top 3​
9​
15.96​
C9: {=TRANSPOSE(ProctorMax(B3:B5, C3:C5))}
10​
109.02​
11​
12​
13​
14​
15​
16​
17​
18​
All 4​
19​
16.01​
C19: {=TRANSPOSE(ProctorMax(B3:B6, C3:C6))}
20​
108.86​
21​
22​
23​
24​
25​
26​
27​
28​
Bottom 3​
29​
16.18​
C29: {=TRANSPOSE(ProctorMax(B4:B6, C4:C6))}
30​
108.74​

Code: 
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
 
Upvote 0
A bug :eek:

B​
C​
D​
2​
Moisture​
Dry Density​
3​
13.8%​
102.2​
4​
15.0%​
107.6​
5​
16.4%​
108.7​
6​
18.5%​
103.6​
7​
8​
Top 3​
9​
16.0%​
C9: {=TRANSPOSE(ProctorMax(B3:B5, C3:C5))}
10​
108.96​
11​
12​
13​
14​
15​
16​
17​
18​
All 4​
19​
16.0%​
C19: {=TRANSPOSE(ProctorMax(B3:B6, C3:C6))}
20​
108.86​
21​
22​
23​
24​
25​
26​
27​
28​
Bottom 3​
29​
16.0%​
C29: {=TRANSPOSE(ProctorMax(B3:B5, C3:C5))}
30​
108.96​

Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
Construction Budget distribution using GAMMADIST Function
Replies
3
Views
155
ibrahimdaas
I
A
  • Question
Price elasticity calculation, with no known curve
Replies
4
Views
279
Avit
A
R
  • Solved
How do I extract the data label of a trendline in VBA?
2
Replies
14
Views
851
RockandGrohl
R
K
  • Question
Drop down lists with formulas
Replies
3
Views
622
etaf
etaf
M
  • Solved
Scatter Graph and connecting points based on location in graph instead of
Replies
3
Views
1K
misterj0shua
M

Forum statistics

Threads
1,214,515
Messages
6,119,972
Members
448,933
Latest member
Bluedbw

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top