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.


[/IMG]


[/IMG]
 

mikerickson

MrExcel MVP
Joined
Jan 15, 2007
Messages
22,875
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
 

salim hasan

Board Regular
Joined
Dec 25, 2013
Messages
103
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:

Forum statistics

Threads
1,084,967
Messages
5,380,881
Members
401,704
Latest member
DravenExcel

Some videos you may like

This Week's Hot Topics

Top