VBA to solve for equation based on missing variable

mpfanalytics

New Member
Joined
Aug 31, 2019
Messages
1
Hi all, first post here.

I've been learning VBA, and I've found the best way for me is to jump into exercises I've never done before. I recently came across a problem and decided to take a shot at it. I'm trying to use VBA to solve for the equation A = (B/C)^D, where any one variable A, B, C, or D is missing, and the others are constants pulled from cells. Ideally I'd like to create a msg box where you can input a value for each variable and it'll solve for the missing variable, but baby steps lol. Any help would be appreciated! I have attached images below of what I've done so far.


J4DFspV.png
[/IMG]


fSIQPoW.png
[/IMG]
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
To find numeric solutions to formulas, it helps to put all the variables on one side of the equation.
Instead of A = (B-C)^D, use ((B-C)^D) - A = 0.
This algebra is best done by the user. VBA (or any programming language) doing algebra is nasty.

If you know 3 of the variables, this becomes a function of one variable. In your example it becomes (4800-750)^2 - A.

One way that I like to solve for zeros of an equation is to use the binary search method.
Code:
Sub test()
    MsgBox FindZeroBetween(-50000000, 50000000)
End Sub

Function FindZeroBetween(startLow As Double, startHigh As Double, Optional Accuracy As Double = 1e-06) As Double
    Dim Low As Double, High As Double, Mid As Double
    
    Rem clean arguments
    Accuracy = Abs(Accuracy)
    If Accuracy = 0 Then Accuracy = 1e-06
    If MyFunction(startLow) < MyFunction(startHigh) Then
        Low = startLow
        High = startHigh
    Else
        Low = startHigh
        High = startLow
    End If
    Rem check
    Select Case Sgn(MyFunction(Low) * MyFunction(High))
        Case Is = 1
        Rem both have same sign, aborth
            MsgBox "start values do not capture zero"
            Exit Function
        Case Is = 0
            Rem one of the startvalues is a zero
            If MyFunction(Low) = 0 Then
                Mid = Low
            Else
                Mid = High
            End If
            MsgBox "MyFunction(" & Mid & ") = " & MyFunction(Mid)
            FindZeroBetween = Mid
            Exit Function
        Case Else
            Rem all is good
    End Select
    
    Rem binary search
    Do
        Mid = (High + Low) / 2
        Select Case MyFunction(Mid)
            Case Is < (-1 * Accuracy)
                Rem mid becomes low
                Low = Mid
            Case Is > Accuracy
                Rem mid becomes high
                High = Mid
            Case Else
                Rem we have a solution
                Exit Do
        End Select
    Loop Until False
    
    MsgBox "MyFunction(" & Mid & ") = " & MyFunction(Mid)
    
    FindZeroBetween = Mid
End Function

Function MyFunction(x As Double) As Double
    MyFunction = ((4800 - 750) ^ 2) - x
End Function
Note that the FindZeroBetween needs two values a and b where F(a) is positive and F(b) is negative.
Note also that binary search is limited to "nice" functions. Continous is the primary requirement, there's a whold body of literature on the limits of binary search.
Note also that because of the way that computers store numbers, its best to look for ABS(F(x)) < delta rather then F(x)=0. Hence the Accuracy variable.

If the function is "nice" enough, Excel can search for and find suitable start points for FindZeroBetween.

Code:
Sub test()
    MsgBox FindZero
End Sub

Function FindZero() As Double
    Dim EndPoint As Double
    EndPoint = 1
    Do While True
        If Sgn(MyFunction(EndPoint) * MyFunction(-1 * EndPoint)) = -1 Then
            Rem good to go
            Exit Do
        Else
            EndPoint = 2 * EndPoint
        End If
    Loop
    FindZero = FindZeroBetween(EndPoint, -1 * EndPoint)
End Function

Function FindZeroBetween(startLow As Double, startHigh As Double, Optional Accuracy As Double = 1e-06) As Double
    Dim Low As Double, High As Double, Mid As Double
    
    Rem clean arguments
    Accuracy = Abs(Accuracy)
    If Accuracy = 0 Then Accuracy = 1e-06
    If MyFunction(startLow) < MyFunction(startHigh) Then
        Low = startLow
        High = startHigh
    Else
        Low = startHigh
        High = startLow
    End If
    Rem check
    Select Case Sgn(MyFunction(Low) * MyFunction(High))
        Case Is = 1
        Rem both have same sign, aborth
            MsgBox "start values do not capture zero"
            Exit Function
        Case Is = 0
            Rem one of the startvalues is a zero
            If MyFunction(Low) = 0 Then
                Mid = Low
            Else
                Mid = High
            End If
            MsgBox "MyFunction(" & Mid & ") = " & MyFunction(Mid)
            FindZeroBetween = Mid
            Exit Function
        Case Else
            Rem all is good
    End Select
    
    Rem binary search
    Do
        Mid = (High + Low) / 2
        Select Case MyFunction(Mid)
            Case Is < (-1 * Accuracy)
                Rem mid becomes low
                Low = Mid
            Case Is > Accuracy
                Rem mid becomes high
                High = Mid
            Case Else
                Rem we have a solution
                Exit Do
        End Select
    Loop Until False
    
    MsgBox "MyFunction(" & Mid & ") = " & MyFunction(Mid)
    
    FindZeroBetween = Mid
End Function

Function MyFunction(x As Double) As Double
    MyFunction = ((4800 - 750) ^ 2) - x
End Function
 
Upvote 0
Try this macro
Code:
Option Explicit
Sub SOLVE_mY_EQ()
Dim  b, c, d
b = Cells(5, 3)
c = IIf(Cells(6, 3) = "" Or Not IsNumeric(Cells(6, 3)) _
    Or Cells(6, 3) = 0, 1, Cells(6, 3))
    Cells(6, 3)=c
d = Cells(7, 3)


Cells(4, 3) = (b / c) ^ d
' Or To Round To 2 digits
'Cells(4, 3) = Round((b / c) ^ d, 2)
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,483
Messages
6,113,919
Members
448,533
Latest member
thietbibeboiwasaco

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