' Modified from Java code found at http://www.merriampark.com/bigsqrt.htm
 ' by Michael Gilleland, Merriam Park Software
 ' The Sqr() function in VBA returns double, which results in precision loss
 ' if you are using the Decimal data type.
 '
 ' This uses Newton's method to calculate the SQRT when higher precision is
 ' required.  The error of this method is compared to that of the
 ' standard calculation.  If the error is greater, than the standard
 ' calculation is used instead.  This should only occur if the number of
 ' iterations is not high enough.
 
 ' The decimal data type was introduced in Excel 2000 and cannot be declared
 ' Explicitly.  You must declare as variant and use CDEC() command to ensure
 ' that decimal data type is used.  This type gives a range of
 ' +/- 79,228,162,514,264,337,593,543,950,335 for integers and
 ' +/- 7.9228162514264337593543950335 for 28 decimal places.
 
Option Explicit 
Option Private Module 
 
 'These are global variables potentially useful for the main subroutine
Private error As Variant 'Error of answer*answer compared to original value
Private iterations As Integer 'Number of iterations required to converge
Private title As String 'Used for main routine msgBox
 
 
 '  //--------------------------
 '  // Get initial approximation
 '  //--------------------------
 'Setting an initial value is not required, but helps to converge faster.
 'The alternative is to always set the initial value to 1
Function getInitialApproximation(n As Variant) As Variant 'Decimal type
    Dim integerPart As Variant 'Decimal type
    Dim length As Integer 
    Dim guess As Variant 'Decimal type
    Dim ONE As Variant 
     
    ONE = CDec("1.00000000000000000000000000000000") 
    integerPart = Round(n, 0) 
    length = Len(integerPart) 
    If (length Mod 2 = 0) Then 
        length = length - 1 
    End If 
    length = length / 2 
    guess = CDec(ONE * 10 ^ length) 
    getInitialApproximation = guess 
End Function 
 '  //----------------
 '  // Get square root
 '  //----------------
Function getBigSquareRoot(n As Variant) As Variant 'Decimal type
     '    // Make sure n is a positive number
    Dim initialGuess As Variant 
    Dim guess, lastGuess As Variant 
    Dim more As Boolean 
    Dim ZERO, ONE, TWO As Variant 
     
    ZERO = CDec("0.0000000000000000000000000000") 
    ONE = CDec(" 0.0000000000000000000000000001") 
    TWO = CDec(" 2.0000000000000000000000000000") 
     
    If (n <= ZERO) Then Exit Function 
     
    initialGuess = getInitialApproximation(n) 
    lastGuess = ZERO 
    guess = initialGuess 
     '// Iterate
    iterations = 0 
    more = True 
     
    While (more) 
        lastGuess = guess 
        guess = CDec(n / guess) 
        guess = CDec(guess + lastGuess) 
        guess = CDec(guess / TWO) 
         
        iterations = iterations + 1 
        If Abs(lastGuess - guess) <= ONE Then 
            more = False 
        End If 
    Wend 
     'In the unexpected case that the error exceeds
     'Excels standard double-precision calculator,
     'Use Excel Calculation instead
    error = CDec(n - guess * guess) 
    If Abs(error) > Abs(getDoubleSquareRootError(n)) Then 
        guess = Sqr(n) 
    End If 
    getBigSquareRoot = CDec(guess) 
End Function 
 ' This calculates the error of the standard Excel Square Root Function.
 ' If this error is less than the high-precision function, there was a
 ' convergance issue and use the standard function instead.
Function getDoubleSquareRootError(n As Variant) As Double 
    Dim sqrt As Double 
    Dim error As Double 
    sqrt = Sqr(n) 
    error = (n - sqrt * sqrt) 
    getDoubleSquareRootError = error 
End Function 
 '  This is a sample case for testing.  change the value of testNums to test
 ' Various scenerios
 '  //-----
 '  // Test
 '  //-----
Sub main() 
    Dim n, sqrt, nIterations As Variant 
    Dim testNums() As Variant 
    Dim response As Integer 
     
    title = "High-Precision Square Root Calculator" 
10: 
     'Request value for calculation
    n = InputBox(Prompt:="Input Value for Square Root Calculation", _ 
    title:=title) 
     'If cancel then exit sub
    If n = "" Then 
        Exit Sub 
    Else 
        On Error GoTo CatchTypeError 
        n = CDec(n) 
    End If 
     'Number must be greater than 0
    If n <= 0 Then 
        InvalidNumberError 
        GoTo 10 
        Exit Sub 
    End If 
     
    On Error GoTo CatchSqrRootError 
    sqrt = getBigSquareRoot(n) 
     
    response = MsgBox(Prompt:="Paste Results in Active Cell?", _ 
    title:=title, _ 
    Buttons:=vbYesNo + vbInformation) 
    If response = VbMsgBoxResult.vbYes Then 
        Application.ActiveCell.Value = sqrt 
    End If 
    MsgBox Prompt:="Computing the square root of: " & n & vbCrLf _ 
    & "Iterations: " & iterations & vbCrLf _ 
    & "Sqrt: " & sqrt & vbCrLf _ 
    & "Sqrt Squared: " & sqrt * sqrt & vbCrLf _ 
    & "Error: " & error, _ 
    title:=title, _ 
    Buttons:=vbApplicationModal 
    Exit Sub 
CatchTypeError: 
    InvalidNumberError 
    Err = False 
    Resume 10 
    Exit Sub 
CatchSqrRootError: 
    MsgBox Prompt:="Calculation Error" & vbCrLf _ 
    & "Value Probably Exceeds Limits", _ 
    title:=title, _ 
    Buttons:=vbExclamation 
    Err = False 
    Resume 10 
    Exit Sub 
End Sub 
Sub InvalidNumberError() 
    Dim msg As String 
    msg = "Invalid Number" & vbCrLf _ 
    & "Please enter number >= 0 and" & vbCrLf _ 
    & "<=79,228,162,514,264,337,593,543,950,335" 
    MsgBox Prompt:=msg, _ 
    title:=title, _ 
    Buttons:=vbExclamation 
End Sub 
Sub Button1_Click() 
    main 
End Sub