Сравнение встроенных и математических функций с заданной точностью

Function Корень_VBA(число)
    Корень_VBA = sqr(число)
End Function

Option Explicit
 
Function LongSqr(iNum As Integer, iLen As Integer) As String
    Dim sngT As Single: sngT = Timer
    Dim sRes As String, sRes2 As String
    sRes = CStr(Int(Sqr(iNum)))
    sRes2 = LongMult(2, sRes)
 
    Dim sOst As String, sNum1 As String
    sOst = LongSub(iNum, LongMult(sRes, sRes))
    '*****************
    If sOst = "0" Then
        LongSqr = sRes
        Exit Function
    End If
    '*****************
    sNum1 = sOst & "00"
 
    Dim i As Integer
 
    Do
        For i = 1 To 10
            If isLarger(LongMult(sRes2 & i, i), sNum1) Then
                '==========================================================
                sOst = LongSub(sNum1, LongMult(sRes2 & CStr(i - 1), i - 1))
                sNum1 = sOst & "00"
 
                sRes = sRes & CStr(i - 1)
                sRes2 = LongMult(2, sRes)
                '==========================================================
 
                Exit For
            End If
        Next i
    Loop While Len(sRes) <= iLen
    Debug.Print Timer - sngT
    LongSqr = sRes
End Function
'{
'    Алгоритм извлечения корня квадратного
'
'    Рассмотрим на примере sqrt(273529).
'    Для нахождения произведем следующие действия:
'    1) десятичную запись числа 273529 разобьем на группы по две цифры, начиная справа;
'    2) для старшей группы, образующей число 27, подберем такую цифру, чтобы ее квадрат был наибольшим, но не превосходил числа 27; такой цифрой будет 5, ее запишем в качестве первой цифры ответа;
'    3) из старшей группы цифр вычтем найденный в предыдущем пункте квадрат первой цифры ответа и к полученной разности 27 – 25 = 2 припишем справа следующую группу цифр 35; получим число 235;
'    4) удвоив записанное в ответе число 5, припишем справа такую цифру , чтобы произведение полученного в результате числа на эту цифру было наибольшим, но не превосходило числа 235; такой цифрой будет 2 (ибо 102 x 2 = 204 < 235, но 103 x 3 = 309 > 235), ее и запишем в качестве второй цифры ответа;
'    5) из числа 235 вычтем найденное в предыдущем пункте произведение 204 и к остатку 31 снесем следующую группу цифр 29; получим число 3129;
'    6) удвоив записанное в ответе число 52, припишем справа такую цифру, чтобы произведение полученного в результате числа на эту цифру было наибольшим, но не превосходило числа 3129; такой цифрой будет 3 (ибо 1043 x 3 = 3129), ее и запишем в качестве третьей цифры ответа;
'    7) разность между снесенным числом 3129 и полученным в предыдущем пункте произведением равна 0, поэтому корень квадратный из числа 273529 извлекается нацело и равен записанному в ответе числу 523.
'}
 
 
'############################################################################################
'###                 [url]http://www.vbnet.ru/articles/showarticle.aspx?id=92[/url]                  ###
'############################################################################################
Public Function ResetZero(ByVal N1 As String) As String
 
    ' просто убираем лишние нули из начала строки (числа): 0004562 -> 4562
 
    On Error Resume Next
    Dim i As Long, Tmp As String
    For i = 1 To Len(N1)
        If Mid$(N1, i, 1) <> "0" Then Exit For    ' передвигаем указатель i по числу, пока на встретим не 0
    Next
    Tmp = Right$(N1, Len(N1) - i + 1)    ' Вырезаем ненужный мусор
 
    ' Если строка состояла из одних нулей, то оставим один нолик на память!
 
    If Tmp = "" Then ResetZero = "0" Else ResetZero = Tmp
End Function
 
Public Function isLarger(ByVal N1 As String, ByVal N2 As String) As Boolean
    On Error Resume Next
    Dim L As Long, i As Long, B1 As Byte, B2 As Byte
    L = Len(N1)
    If L <> Len(N2) Then
        isLarger = L > Len(N2)    'если длины чисел не равны, то больше то, чья длина больше!
    Else
 
        ' Теперь длины чисел равны…
 
        If N1 Like N2 Then
            isLarger = True    ' проверка случая N1=N2
            Exit Function
        End If
        isLarger = False    ' теперь: N1<>N2 и у них одинаковая длина -> поразрядная проверка:
        For i = 1 To L
            B1 = CByte(Mid$(N1, i, 1))
            B2 = CByte(Mid$(N2, i, 1))
            Select Case B1
            Case Is < B2: Exit Function    ' N1<N2
            Case Is > B2    ' N2<N1
                isLarger = True
                Exit Function
            End Select
        Next
    End If
End Function
 
Public Function LongAdd(ByVal N1 As String, ByVal N2 As String) As String
 
    ' Самая нужная и полезная функция (также как и вычитание)! Ведь на её основе можно сделать умножение и возведение в степень.
    ' На основе вычитания можно сделать деление и MOD
 
    On Error Resume Next
    Dim Tmp As String, Pre As String, Mas() As Byte, L As Long, i As Long
 
    ' сделаем так, чтобы в N1 хранилось более длинное число, к N2 припишем недостающие разряды нулями.
 
    If Len(N2) > Len(N1) Then
        Tmp = N1
        N1 = N2
        N2 = Tmp
    End If
    L = Len(N1)
    N2 = String$(L - Len(N2), "0") & N2
 
    ' А вот и массив! Заметьте, что его размер 1..L. Хотя в результате может получиться число длиной максимум L+1
 
    ReDim Mas(1 To L)
 
    ' Заполняем каждый элемент массива соответствующей суммой
 
    For i = 1 To L
        Mas(i) = CByte(Mid$(N1, i, 1)) + CByte(Mid$(N2, i, 1))
    Next
 
    ' Начиная с предпоследней ячейки, нормализуем массив. Число 48 прибавляется, чтобы правильно конвертировать массив в String.
 
    For i = L - 1 To 1 Step -1
        If Mas(i + 1) > 9 Then Mas(i) = Mas(i) + 1
        Mas(i + 1) = (Mas(i + 1) Mod 10) + 48
    Next
 
    ' Проверяем, не вылез ли L+1 разряд
 
    If Mas(1) > 9 Then
        Pre = "1"
        Mas(1) = Mas(1) + 38    ' 38=48-10
    Else
        Pre = ""
        Mas(1) = Mas(1) + 48
    End If
 
    ' Конвертируем массив в String
 
    Tmp = StrConv(Mas, vbUnicode)
    i = InStr(Tmp, Chr(0))
    If i > 0 Then Tmp = Left$(Tmp, i - 1)
 
    ' Опля, всё готово!
 
    LongAdd = Pre & Tmp
End Function
 
Public Function LongSub(ByVal N1 As String, ByVal N2 As String) As String
 
    ' действие обратное сложению, не менее полезно. Начало эквивалентно LONGADD:
 
    On Error Resume Next
    Dim Tmp As String, Mas() As Byte, L As Long, i As Long
    If Len(N2) > Len(N1) Then
        Tmp = N1
        N1 = N2
        N2 = Tmp
    End If
    L = Len(N1)
    N2 = String$(L - Len(N2), "0") & N2
    ReDim Mas(1 To L)
    For i = 1 To L
        Mas(i) = 10 + CByte(Mid$(N1, i, 1)) - CByte(Mid$(N2, i, 1))    ' а здесь отнимаем!
    Next
    For i = L - 1 To 1 Step -1
        If Mas(i + 1) < 10 Then Mas(i) = Mas(i) - 1 Else Mas(i) = Mas(i)    ' и здесь небольшое отличие
        Mas(i + 1) = Mas(i + 1) Mod 10
    Next
    Mas(1) = Mas(1) Mod 10    ' проверка на L+1 разряд не нужна.
    For i = 1 To L
        Mas(i) = Mas(i) + 48    ' корректируем значения для StrConv
    Next
 
    ' MAS->String
 
    Tmp = StrConv(Mas, vbUnicode)
    i = InStr(Tmp, Chr(0))
    If i > 0 Then Tmp = Left$(Tmp, i - 1)
 
    ' Убираем лишние нули из начала числа
 
    Tmp = ResetZero(Tmp)
 
    ' Если N1=N2, то мы столкнёмся с этой неприятной ситуацией:
 
    If Tmp = "" Then LongSub = "0" Else LongSub = Tmp
End Function
 
Public Function LongMult(ByVal N1 As String, ByVal N2 As String) As String
    On Error Resume Next
    Dim Tmp As String, Mas() As Long, L As Long, i As Long, J As Long, ByteMas() As Byte, P As Long
 
    ' в начале как всегда!
 
    If Len(N2) > Len(N1) Then
        Tmp = N1
        N1 = N2
        N2 = Tmp
    End If
    L = Len(N1)
    N2 = String$(L - Len(N2), "0") & N2
 
    ' Массив берём из 2*L элементов. Т.к. 99*99=9801
 
    ReDim Mas(1 To 2 * L)
    For i = 1 To L * 2
        Mas(i) = 0
    Next
    For i = L To 1 Step -1
        For J = L To 1 Step -1    ' двойной цикл… вот тут-то и влияние на скорость!
            P = i + J    ' адрес куда будем класть результат. Вспоминайте перемножение столбиком!
            Mas(P) = Mas(P) + CLng(Mid$(N1, J, 1)) * CLng(Mid$(N2, i, 1))
        Next
    Next
 
    'знакомая нам нормализация массива начинаемая с предпоследнего элемента
 
    P = 2 * L - 1
    For i = P To 1 Step -1
        J = i + 1
        Mas(i) = Mas(i) + Int(Mas(J) / 10)
        Mas(J) = (Mas(J) Mod 10) + 48
    Next
    Mas(1) = Mas(1) + 48
 
    'теперь Long mas -> byte mas (для того, чтобы можно было использовать StrConv)
 
    ReDim ByteMas(1 To 2 * L)
    P = 2 * L
    For i = 1 To P
        ByteMas(i) = CByte(Mas(i))
    Next
 
    ' тоже как всегда...
 
    Tmp = StrConv(ByteMas, vbUnicode)
    i = InStr(Tmp, Chr(0))
    If i > 0 Then Tmp = Left$(Tmp, i - 1)
    LongMult = ResetZero(Tmp)    'и последний штрих: удаляем лишние нули. А их может быть очень много
End Function
 
 
'Sub sqr2()
'    ' 665857/470832 = 1.4142135623746…
'    Dim sOst As String
'    Debug.Print LongDiv("665857000000000000000000000", 470832, sOst)
'End Sub
 
'Public Function LongDiv(ByVal N1 As String, ByVal N2 As String, ByRef Ostatok As String) As String
'    On Error Resume Next
'    Dim i As Long, Tmp As String, Mas(1 To 9) As String, IntPart As String, PreIntPart As String
'    LongDiv = "0"
'    Ostatok = "0"
'
'    ' В начале некоторые частные случаи деления:
'
'    If N1 = "0" Then Exit Function
'    If N2 = "0" Then
'        MsgBox "ERROR: Division by Zero!"
'        Exit Function
'    End If
'    If N2 = "1" Then
'        LongDiv = N1
'        Ostatok = "0"
'        Exit Function
'    End If
'    If N1 Like N2 Then
'        LongDiv = "1"
'        Exit Function
'    End If
'    If isLarger(N2, N1) Then
'        Ostatok = N1
'        Exit Function
'    End If
'
'    ' А дальше несколько дополненный LongMod. Пусть разбор этого примера будет на Вашей совести
'
'    IntPart = "0"
'    Ostatok = N1
'    Do While isLarger(Ostatok, N2)
'        Tmp = N2 & String$(Len(Ostatok) - Len(N2), "0")
'        PreIntPart = "1" & String$(Len(Ostatok) - Len(N2), "0")
'        If Tmp Like Ostatok Then
'            LongDiv = LongAdd(IntPart, PreIntPart)
'            Ostatok = "0"
'            Exit Function
'        End If
'        If isLarger(Tmp, Ostatok) Then
'            Tmp = Left$(Tmp, Len(Tmp) - 1)
'            PreIntPart = Left$(PreIntPart, Len(PreIntPart) - 1)
'        End If
'        Mas(1) = Tmp
'        For i = 2 To 10
'            Mas(i) = LongAdd(Mas(i - 1), Tmp)
'            If isLarger(Mas(i), Ostatok) Or (Mas(i) Like Ostatok) Then Exit For
'        Next
'        IntPart = LongAdd(IntPart, Replace$(PreIntPart, "1", i - 1))
'        Ostatok = LongSub(Ostatok, Mas(i - 1))
'    Loop
'    LongDiv = IntPart
'End Function

MsgBox LongSqr(2,100)

MsgBox Abs(Sqr(2) - LongSqr(2, 56))

    Dim d As Double
    d = Sqr(iNum)
    If Left(Int(d), 1) = 0 Then
        LongSqr = "0." & sRes
    Else
        LongSqr = Left(sRes, InStr(1, d, ".") - 1) & "." & Mid(sRes, InStr(1, d, "."))
    End If