エクセルＶＢＡで有効数字34桁を扱う　　３４桁版/３体問題
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　           　　　
　◆エクセル34桁関数モジュール　 　　　　　　　　　　　　　　　　　３０桁版

  IEEE754　decimal128（十 進四倍精度）　に合わせる　　34桁　指数最大値-6143〜+6144　

　 加減乗除・平方根　　■加34(a,b)　■減34(a,b)　■乗34(a,b)　■除34(a,b)　★Sqr34(c)　

 その他オプション関数

精度コンバータ           
■34↓15(c)
■15↑34(c)　　 　　　      
※注意 15桁はDouble型　34桁はString型
円周率　　　　　　　      
■PI34()　

累乗・Ｎ乗根　　　　 ■累34(a,R) ■N乗根34(a,N)　　　
※注意　RはDouble型(3.5桁 まで)　NはLong型（9999まで)



--------------------------------　以下、作成中、検討中ほか　------------------- ---------------------

比較演算 ■比較34(a,b)　　　　　　
 ・・・　検討中
ROUND関数
 ■ROUND34(a,N) ・・・　検討中（Ｎ≧0　限定とするかどうか）
INT関数　
・・・　仕様上できない(解釈によるが)
乱数　　　　　　　　 ■乱数34()　　　　　　　　　　　　 ・・・　作らない
ＭＯＤ関数　 ■MOD34(a,b)　　　　　　　　　　　 ・・・　作らない

　ex.  10　+　（-7）＝3　　10　-　(-7)＝17　　　10　×　2　＝ 20　　　10　÷　(-7)　＝　-1.4285・・・　　√２　＝　1.41421・・・
　


◆◆◆◆ 　以下　標準モジュールに置く　　◆◆◆◆

'　★自己責任でお使いください。

Sub 計算精度34桁_サンプル()
' IEEE 754  十進四倍精度　34桁(34文字)　指数最大値　-6143　〜　6144

Dim cls34 As clstaby_preci34
Set cls34 = New clstaby_preci34  '　インスタンスを作成
Dim abc As Double

  '10　と　-7　　加減乗除　の例
   AA = "1.00000000000000000000000000000000000E+0001"
   bb = "-7.00000000000000000000000000000000000E+0000"
   cc = "2.00000000000000000000000000000000000E+0000"

    加算結果 = cls34.■加34(AA, bb)
    減算結果 = cls34.■減34(AA, bb)
    乗算結果 = cls34.■乗34(AA, bb)
    除算結果 = cls34.■除34(AA, bb)
    平方根 = cls34.★Sqr34(cc)
    N乗根 = cls34.■N乗根34(cc, 2)
    累乗 = cls34.■累乗34(cc, 0.5)
   
    Debug.Print "aa=　" & AA
    Debug.Print "bb=　" & bb
    Debug.Print "cc=　" & cc
    Debug.Print "加算結果= " & 加算結果
    Debug.Print "減算結果= " & 減算結果
    Debug.Print "乗算結果= " & 乗算結果
    Debug.Print "除算結果= " & 除算結果
    Debug.Print "平方根　= " & 平方根
    Debug.Print "N乗根　= " & N乗根
    Debug.Print "累乗　= " & 累乗

Set cls34 = Nothing

End Sub



◆◆◆◆　以下　クラスモジュールに置く　-　仮称　 clstaby_preci34　◆◆◆◆

'　★自己責任でお使いください。

Option Explicit
Option Base 1
Function ■累乗34(ByVal ccc As String, ByVal R As Double) As String
         ■累乗34 = Unify34(★累乗36(ccc, R))
End Function
Function ★累乗36(ByVal ccc As String, ByVal R As Double) As String  '内部関数
 
If Left$(ccc, 35) = "0.000000000000000000000000000000000" Then
    MsgBox "すいません。　0の累乗は扱えない仕様としています。"
    End
End If
    '条件１
    If R > 10 Or R < -10 Then
      MsgBox "累乗：　累乗の定義域　10〜-10　をはずれました　終了します"
      End
    End If
    '条件２
    If Int(Abs(R * 1000)) <> Abs(R * 1000) Then
      MsgBox "累乗：　累乗の定義域（有効数字4桁）を超えています　終了します"
      End
    End If
    'Ｒの有理化　分子／分母
    Dim 絶対R As Double
    Dim 分子 As Long, 分母 As Long
    Dim K As Integer
    Dim HT As Integer
   
    絶対R = Abs(R)              '1.234
    分子 = 絶対R * 1000         '1234
    分母 = 1000                 '1000
   
    Do
      HT = 0
      For K = 2 To 分母
        If Int(分子 / K) = (分子 / K) And Int(分母 / K) = (分母 / K) Then
             分子 = 分子 / K
             分母 = 分母 / K
             HT = 1
             Exit For
        End If
      Next K
    Loop While HT = 1

    Dim 整数部 As Integer
    整数部 = Int(分子 / 分母)
    分子 = 分子 - 分母 * 整数部
 
    Dim buf根 As String, buf根乗 As String, buf整数分 As String
    Dim 数字1 As String
    数字1 = "1.00000000000000000000000000000000000E+0000"
   
    buf整数分 = 数字1
    buf根乗 = 数字1
    If 分母 <> 1 Then
      buf根 = ★N乗根36(ccc, 分母)
      Else
      buf根 = ccc
    End If
       
        For K = 1 To 整数部
          buf整数分 = Multipl_taby34(buf整数分, ccc)
        Next K
       
        For K = 1 To 分子
          buf根乗 = Multipl_taby34(buf根乗, buf根)
        Next K
       
     Dim ans As String
      ans = Multipl_taby34(buf整数分, buf根乗)
     
     If R < 0 Then
      ans = Divide_taby34(数字1, ans)        '　指数が負のときは逆数
     End If
    
     ★累乗36 = ans

End Function
Function ■N乗根34(ByVal ccc As String, ByVal N As Integer) As String
      ■N乗根34 = Unify34(★N乗根36(ccc, N))
End Function
Function ★N乗根36(ByVal aaa As String, ByVal N As Long) As String
    '36桁内部関数とする
Dim ans000 As String
Dim Xn As String, Xn0 As String, Xn1 As String
Dim 数字1 As String
Dim 整数N As String
Dim 整数N_1 As String
   
    If N > 9999 Then
        MsgBox "　べき乗根：　Nの定義域　9999　を超えています　終了します。　"
        End
    End If
    数字1 = "1.00000000000000000000000000000000000E+0000"
    整数N = CStr(N) & ".00000000000000000000000000000000000E+0000"
    整数N_1 = CStr(N - 1) & ".00000000000000000000000000000000000E+0000"
    整数N = Multipl_taby34(数字1, 整数N)          '正規化
    整数N_1 = Multipl_taby34(数字1, 整数N_1)      '正規化
    
     Xn0 = aaa
     Xn = Xn0
     If N = 0 Then
          ans000 = "1.00000000000000000000000000000000000E+0000"  '36桁の1
      End If
     
     
Dim K As Integer, K2 As Integer
Dim buff1 As String, buff2 As String, buff3 As String, buff4 As String

    For K = 1 To 1000
        'Ｘn1 = ( (N-1)*Ｘn+ Ａ/(Ｘn^(N-1)) ) / N
        buff1 = Multipl_taby34(整数N_1, Xn)           '　(N-1)*Ｘn
        buff2 = 数字1
        For K2 = 1 To (N - 1)
            buff2 = Multipl_taby34(buff2, Xn)         '　(Ｘn^(N-1))
        Next K2
        buff3 = Divide_taby34(aaa, buff2)             '　Ａ/(Ｘn^(N-1)
        buff4 = Add_taby34(buff1, buff3)              '　(N-1)*Ｘn　+　Ａ/(Ｘn^(N-1)
        Xn1 = Divide_taby34(buff4, 整数N)              '　Ｘn1 = ( (N-1)*Ｘn+ Ａ/(Ｘn^(N-1)) ) / N
        If Left$(Xn, 36) = Left$(Xn1, 36) Then        ' 35桁文字+”.”文字分が一致したら終了
          Exit For
        End If
        Xn = Xn1
    Next K
   
       ans000 = Xn1
       ★N乗根36 = ans000
End Function

Function ■15↑34(ByVal ddd As Double) As String
Dim ans1 As String
Dim buff1 As String
Dim K As Integer

   buff1 = CStr(ddd)
  
   '12300000#　形式の　　・・・　#　削除
'   If Right$(buff1, 1) = "＃" Then
'       buff1 = Left$(buff1, Len(buff1) - 1)
'   End If
  
    '正の整数の場合
    If InStr(buff1, ".") = 0 And InStr(buff1, "E") = 0 And Left$(buff1, 1) <> "-" Then        ' 正の整数　123
           buff1 = buff1 & "."
           For K = 1 To (35 - Len(buff1))
             buff1 = buff1 & "0"
           Next K
           buff1 = buff1 & "  E+0000"
    End If
    '負の整数の場合
    If InStr(buff1, ".") = 0 And InStr(buff1, "E") = 0 And Left$(buff1, 1) = "-" Then         ' 負の整数　-123
           buff1 = buff1 & "."
           For K = 1 To (36 - Len(buff1))
             buff1 = buff1 & "0"
           Next K
           buff1 = buff1 & "  E+0000"
    End If
    '正の小数点あり
    If InStr(buff1, ".") > 1 And InStr(buff1, "E") = 0 And Left$(buff1, 1) <> "-" Then          ' 正の小数　12.3
          For K = 1 To (35 - Len(buff1))
             buff1 = buff1 & "0"
           Next K
           buff1 = buff1 & "  E+0000"
    End If
    '負の小数点あり
    If InStr(buff1, ".") > 1 And InStr(buff1, "E") = 0 And Left$(buff1, 1) = "-" Then           ' 負の小数　-12.3
          For K = 1 To (36 - Len(buff1))
             buff1 = buff1 & "0"
          Next K
          buff1 = buff1 & "  E+0000"
    End If

    '正の　123.45E+00型
    Dim buff1前 As String
    Dim buff1_Exp As String

    If InStr(buff1, ".") > 1 And InStr(buff1, "E") > 1 And Left$(buff1, 1) <> "-" Then           ' 正の小数　12.3E+00
          buff1前 = Left$(buff1, (InStr(buff1, "E") - 1))
          buff1_Exp = Right$(buff1, Len(buff1) - InStr(buff1, "E"))
          For K = 1 To (35 - Len(buff1前))
             buff1前 = buff1前 & "0"
          Next K
         
          If Len(buff1_Exp) = 4 Then
               buff1_Exp = Left$(buff1_Exp, 1) & "0" & Right$(buff1_Exp, 3)
              ElseIf Len(buff1_Exp) = 3 Then
               buff1_Exp = Left$(buff1_Exp, 1) & "00" & Right$(buff1_Exp, 2)
              ElseIf Len(buff1_Exp) = 2 Then
               buff1_Exp = Left$(buff1_Exp, 1) & "000" & Right$(buff1_Exp, 1)
           End If
        buff1 = buff1前 & "  E" & buff1_Exp
    End If
   
   
    '負の　123.45E+00型
     If InStr(buff1, ".") > 1 And InStr(buff1, "E") > 1 And Left$(buff1, 1) = "-" Then           ' 負の小数　-12.3E+00
          buff1前 = Left$(buff1, (InStr(buff1, "E") - 1))
          buff1_Exp = Right$(buff1, Len(buff1) - InStr(buff1, "E"))
          For K = 1 To (36 - Len(buff1前))
             buff1前 = buff1前 & "0"
          Next K
         
          If Len(buff1_Exp) = 4 Then
               buff1_Exp = Left$(buff1_Exp, 1) & "0" & Right$(buff1_Exp, 3)
              ElseIf Len(buff1_Exp) = 3 Then
               buff1_Exp = Left$(buff1_Exp, 1) & "00" & Right$(buff1_Exp, 2)
              ElseIf Len(buff1_Exp) = 2 Then
               buff1_Exp = Left$(buff1_Exp, 1) & "000" & Right$(buff1_Exp, 1)
           End If
        buff1 = buff1前 & "  E" & buff1_Exp
    End If

   
   
    '正規化
    Dim 数字1 As String
    数字1 = "1.00000000000000000000000000000000000E+0000"
    ans1 = Multipl_taby34(文字_パッチ(buff1), 数字1) '
    ■15↑34 = Unify34(ans1)                        '　Unify34で34桁へ整形
   
End Function
Function ■34↓15(ByVal ccc As String) As Double
Dim ans1 As Double
         ans1 = CDbl(Left$(ccc, 18)) * 10 ^ (CDbl(Right$(ccc, 5)))
         ■34↓15 = ans1
End Function
Function ★PI34() As String
         ★PI34 = "3.141592653589793238462643383279503  E+0000" '34桁返し　1+5×7　=　36桁　⇒　34桁へ丸める　外部用
End Function
Function PI36() As String
  PI36 = "3.14159265358979323846264338327950288E+0000" '36桁返し　1+5×7　=　36桁　内部用
End Function
Function ■加34(ByVal aa1 As String, ByVal aa2 As String) As String
Dim buf1 As String, buf2 As String
         buf1 = 文字_パッチ(aa1)
         buf2 = 文字_パッチ(aa2)
         ■加34 = Unify34(Add_taby34(buf1, buf2))
End Function
Function ■減34(ByVal aa1 As String, ByVal aa2 As String) As String
Dim buf1 As String, buf2 As String
         buf1 = 文字_パッチ(aa1)
         buf2 = 文字_パッチ(aa2)
         ■減34 = Unify34(Subtrac_taby34(buf1, buf2))
End Function
Function ■乗34(ByVal aa1 As String, ByVal aa2 As String) As String
Dim buf1 As String, buf2 As String
         buf1 = 文字_パッチ(aa1)
         buf2 = 文字_パッチ(aa2)
         ■乗34 = Unify34(Multipl_taby34(buf1, buf2))
End Function
Function ■除34(ByVal aa1 As String, ByVal aa2 As String) As String
Dim buf1 As String, buf2 As String
         buf1 = 文字_パッチ(aa1)
         buf2 = 文字_パッチ(aa2)
         ■除34 = Unify34(Divide_taby34(buf1, buf2))
End Function
Function ★Sqr34(ByVal ccc As String) As String
Dim buf1 As String
         buf1 = 文字_パッチ(ccc)
         ★Sqr34 = Unify34(Sqr_taby34(buf1))
End Function
Function 文字_パッチ(ByVal xxx As String) As String '空白を0に変換
Dim K As Integer, HT As Integer
Dim ans00 As String

  ans00 = xxx
  For K = 1 To 1000
    HT = 0
    If InStr(ans00, " ") > 0 Then
      ans00 = Left$(ans00, InStr(1, ans00, " ") - 1) & "0" & Right$(ans00, Len(ans00) - InStr(1, ans00, " "))
      HT = 1
    End If
    If HT = 0 Then Exit For
  Next K
 
  文字_パッチ = ans00
 
End Function
Function Unify34(ByVal xx1 As String) As String
     '1+5×7　=　36桁　⇒　34桁へ丸める
     '内部計算は36桁で行い出力は34桁へ戻す

    Dim buff1 As String, Rev_xx1 As String
    Dim 数字_ゲタ05 As String
    Dim ans As String
   
      数字_ゲタ05 = "0.00000000000000000000000000000000050" & Right$(xx1, 6)
     
      If xx1 = "0.00000000000000000000000000000000000E+0000" Then
           buff1 = xx1  '　0なら　そのまま
         ElseIf Left$(xx1, 1) <> "-" Then
           buff1 = Add_taby34(xx1, 数字_ゲタ05)
         ElseIf Left$(xx1, 1) = "-" Then
           Rev_xx1 = Right$(xx1, Len(xx1) - 1) '正にする
           buff1 = "-" & Add_taby34(Rev_xx1, 数字_ゲタ05)  '0.5を足し、−　にする
      End If

      ans = Left$(buff1, InStr(1, buff1, "E") - 3) & "  " & Right$(buff1, 6)

      '-6143〜+6144はエラーとする
      If CLng(Right$(ans, 5)) > 6144 Or CLng(Right$(ans, 5)) < -6143 Then
          MsgBox "オーバーフローまたはアンダーフロー　" & Right$(ans, 6)
          End
      End If

      Unify34 = ans

End Function

Function Sqr_taby34(ByVal cc2 As String) As String
'平方根
Dim K As Integer
Dim Xn0 As String, Xn As String, Xn1 As String
Dim bb2 As String
Dim ans As String

If Left$(cc2, 35) = "0.000000000000000000000000000000000" Then '　0の場合の処理
  ans = "0.00000000000000000000000000000000000E+0000"
 Else

If Left$(cc2, 1) = "-" Then
    MsgBox "√-n　型　　エラーです"
    End
End If

Dim 数字1 As String
数字1 = "1.00000000000000000000000000000000000E+0000"
bb2 = Multipl_taby34(数字1, cc2)  '　念のため　一旦、数字を正規化する


Dim 数字2
数字2 = "2.00000000000000000000000000000000000E+0000"

'　漸化式　Ｘn+1＝（Ｘn　＋　Ａ／Ｘｎ）／２　を 使う

    Xn0 = bb2
    Xn = Xn0

    Dim buff1 As String, buff2 As String

    For K = 1 To 1000
        buff1 = Divide_taby34(bb2, Xn)       'Ａ／Ｘn
        buff2 = Add_taby34(Xn, buff1)        'Ｘn　+　Ａ／Ｘn
        Xn1 = Divide_taby34(buff2, 数字2)    '（Ｘn　+　Ａ／Ｘn）／２
       
        If Left$(Xn, 36) = Left$(Xn1, 36) Then
            Exit For
        End If
        Xn = Xn1
    Next K

    ans = Xn1
   
End If
   
    Sqr_taby34 = ans


End Function

Function Divide_taby34(ByVal bb1 As String, ByVal cc2 As String) As String
'割り算
Dim K As Integer
Dim Xn0 As String, Xn As String, Xn1 As String
Dim buf_1 As String, buf_2  As String
Dim bb2 As String

bb2 = cc2
'正規化する　0.00001234・・×10^○○　⇒　1.2345・・×10^●●
Dim 数字1 As String
数字1 = "1.00000000000000000000000000000000000E+0000"
bb2 = Multipl_taby34(数字1, cc2)  '　一旦、数字を正規化する
   

'ニュートン法でまず　１／bb2（除数）を求める　　 Ｘn1　＝　Ｘn *（２　−　Ａ*Ｘn）
'ループ回数は最低5回　2^6　=　64桁　＞　34桁
'Ｘnの初期値には整数部の逆数を充てる
Dim 正負符号bb2 As String
Dim 整数部絶対値bb2 As Double
Dim Exp正負bb2 As String
Dim Inv_Exp正負bb2 As String

    If Left$(bb2, 1) = "-" Then
        正負符号bb2 = "-"
      Else
        正負符号bb2 = ""       'null　は　+　の意味
    End If

    整数部絶対値bb2 = Abs(CDbl(Left$(bb2, InStr(bb2, ".") - 1)))
    Exp正負bb2 = Mid$(bb2, InStr(bb2, "E") + 1, 1)

    If Exp正負bb2 = "+" And Right$(bb2, 6) <> "E+0000" Then      '
          Inv_Exp正負bb2 = "-"
        Else
          Inv_Exp正負bb2 = "+"    '
    End If

   Dim 初期値用buf As Double, 初期値用buf2 As Double
   Dim 文字buf
    初期値用buf = CDbl(CStr(整数部絶対値bb2) & "." & Mid$(bb2, (InStr(bb2, ".") + 1), 15))
    初期値用buf2 = 1 / 初期値用buf
  
    文字buf = CStr(初期値用buf2)
   
    If Len(文字buf) = 1 Then        '整数の場合の回避策　1.0000・・・
        文字buf = 文字buf & "."
    End If
   
    For K = 1 To 1000
       If Len(文字buf) < 37 Then
          文字buf = 文字buf & "0"
       End If
       If Len(文字buf) = 37 Then
         Exit For
       End If
    Next K

    Xn0 = 正負符号bb2 & 文字buf & "E" & Inv_Exp正負bb2 & Right$(bb2, 4)
       
    Xn0 = Multipl_taby34(数字1, Xn0)  '正規化
    Xn = Xn0
   
   
    Dim 数字2 As String
    数字2 = "2.00000000000000000000000000000000000E+0000"
   
    For K = 1 To 10000
        buf_1 = Multipl_taby34(bb2, Xn)              '　Ａ*Ｘn
        buf_2 = Subtrac_taby34(数字2, buf_1)         '　２　-　Ａ*Ｘn
        Xn1 = Multipl_taby34(Xn, buf_2)              '　Ｘn　*（２　-　Ａ*Ｘn）
       
        If Left$(Xn, 1) = "-" And Left$(Xn, 5 * 7 + 3) = Left$(Xn1, 5 * 7 + 3) Then
             Exit For
           ElseIf InStr(Xn, ".") = 2 And Left$(Xn, 5 * 7 + 2) = Left$(Xn1, 5 * 7 + 2) Then
             Exit For
        End If
       
        Xn = Xn1
    Next K
   
    Dim 逆数_bb2 As String
    逆数_bb2 = Xn1
   
   
    Dim ans As String
    ans = Multipl_taby34(bb1, 逆数_bb2)               'bb1　*　1/bb2
   
    Divide_taby34 = ans
   
End Function
Function Multipl_taby34(ByVal bb1 As String, ByVal bb2 As String) As String
'掛け算
Dim ans As String
Dim KKK As Integer, K As Integer, K2 As Integer
Dim deci_head34(2) As String
Dim deci_正負_head34(2) As String
Dim deci_body34(2, 7) As String
Dim deci_E_符号34(2) As String
Dim deci_E_body34(2) As String

If Left$(bb1, 35) = "0.000000000000000000000000000000000" Or Left$(bb2, 35) = "0.000000000000000000000000000000000" Then
   ans = "0.00000000000000000000000000000000000E+0000"

   Else


'以下、文字列の分解・解体
 deci_head34(1) = Left$(bb1, InStr(1, bb1, ".") - 1) ' .小数点より前
 deci_head34(2) = Left$(bb2, InStr(1, bb2, ".") - 1) ' .小数点より前
'-でない場合は強制的に　+　を付加する
 If Left$(deci_head34(1), 1) <> "-" Then
   deci_正負_head34(1) = "+"
   deci_head34(1) = "+" & deci_head34(1)
   Else
   deci_正負_head34(1) = "-"
 End If
 If Left$(deci_head34(2), 1) <> "-" Then
   deci_正負_head34(2) = "+"
   deci_head34(2) = "+" & deci_head34(2)
   Else
   deci_正負_head34(2) = "-"
 End If
 
 deci_body34(1, 1) = Mid$(bb1, InStr(bb1, ".") + 1 + 5 * 0, 5)
 deci_body34(1, 2) = Mid$(bb1, InStr(bb1, ".") + 1 + 5 * 1, 5)
 deci_body34(1, 3) = Mid$(bb1, InStr(bb1, ".") + 1 + 5 * 2, 5)
 deci_body34(1, 4) = Mid$(bb1, InStr(bb1, ".") + 1 + 5 * 3, 5)
 deci_body34(1, 5) = Mid$(bb1, InStr(bb1, ".") + 1 + 5 * 4, 5)
 deci_body34(1, 6) = Mid$(bb1, InStr(bb1, ".") + 1 + 5 * 5, 5)
 deci_body34(1, 7) = Mid$(bb1, InStr(bb1, ".") + 1 + 5 * 6, 5)
 
 deci_body34(2, 1) = Mid$(bb2, InStr(bb2, ".") + 1 + 5 * 0, 5)
 deci_body34(2, 2) = Mid$(bb2, InStr(bb2, ".") + 1 + 5 * 1, 5)
 deci_body34(2, 3) = Mid$(bb2, InStr(bb2, ".") + 1 + 5 * 2, 5)
 deci_body34(2, 4) = Mid$(bb2, InStr(bb2, ".") + 1 + 5 * 3, 5)
 deci_body34(2, 5) = Mid$(bb2, InStr(bb2, ".") + 1 + 5 * 4, 5)
 deci_body34(2, 6) = Mid$(bb2, InStr(bb2, ".") + 1 + 5 * 5, 5)
 deci_body34(2, 7) = Mid$(bb2, InStr(bb2, ".") + 1 + 5 * 6, 5)
 
 deci_E_符号34(1) = Mid$(bb1, InStr(1, bb1, "E") + 1, 1)
 deci_E_符号34(2) = Mid$(bb2, InStr(1, bb2, "E") + 1, 1)
 deci_E_body34(1) = Right$(bb1, 4)
 deci_E_body34(2) = Right$(bb2, 4)
 '解体終了


'計算できるようにLong型へ変換
'計算用のバッファ　　★注意！！　Option　Base　1　の関係で整数部が　『1』
  Dim culc_buf1(8) As Double, culc_buf2(8) As Double
  Dim culc_reslt(16) As Double                         '　LONG型の仕様は9桁弱までなのでDouble型
 
      culc_buf1(1) = Abs(CDbl(deci_head34(1)))         '　絶対値で入れる
      culc_buf2(1) = Abs(CDbl(deci_head34(2)))         '　絶対値で入れる
      For K = 2 To 8
       culc_buf1(K) = Abs(CDbl(deci_body34(1, K - 1))) '　絶対値で入れる
       culc_buf2(K) = Abs(CDbl(deci_body34(2, K - 1))) '　絶対値で入れる
      Next K
 

'掛け算を実行　　Option base　0　なら　先頭が10^0乗になる
'乗算の場合は単純に掛けていく　5桁×5桁⇒10桁
 Dim L As Integer
 
   For K2 = 1 To 8
        For K = 1 To 8
           culc_reslt(K + K2) = culc_buf1(K) * culc_buf2(K2) + culc_reslt(K + K2)    '全桁計算するのはムダだが
        Next K
   Next K2

   Dim HT As Integer
   Do  '　桁上処理
        HT = 0
        For K = 16 To 3 Step -1
           If culc_reslt(K) >= 10 ^ 5 Then
             culc_reslt(K - 1) = culc_reslt(K - 1) + Int(culc_reslt(K) / 10 ^ 5)
             culc_reslt(K) = culc_reslt(K) - Int(culc_reslt(K) / 10 ^ 5) * 10 ^ 5
             HT = 1
           End If
        Next K
   Loop Until HT = 0    '桁上げ処理がなくなるまで


If culc_reslt(1) <> 0 Then
    MsgBox "エラーです。"
    Stop
End If


Dim 桁シフトcnt As Integer
    桁シフトcnt = 0

Do
    HT = 0
    '最上位が10以上なら、全桁右へシフトする
    If culc_reslt(2) >= 10 Then
      For K = 1 To 15
           culc_reslt(K + 1) = culc_reslt(K + 1) + (culc_reslt(K) - Int(culc_reslt(K) / 10) * 10) * 10 ^ 5
           culc_reslt(K) = Int(culc_reslt(K) / 10)
      Next K
      桁シフトcnt = 桁シフトcnt + 1
      HT = 1
    End If
Loop Until HT = 0
 
 
  Dim 桁シフトcnt2 As Integer
      桁シフトcnt2 = 0
 
  Do
   HT = 0
   '最上位が　0　なら、全桁左へシフトする
        If culc_reslt(2) = 0 Then
          For K = 2 To 16
               culc_reslt(K) = culc_reslt(K) * 10
          Next K
          For K = 2 To 15
               culc_reslt(K) = culc_reslt(K) + Int(culc_reslt(K + 1) / 10 ^ 5)
               culc_reslt(K + 1) = culc_reslt(K + 1) - Int(culc_reslt(K + 1) / 10 ^ 5) * 10 ^ 5
          Next K
          桁シフトcnt2 = 桁シフトcnt2 + 1
          HT = 1
        End If
    Loop Until HT = 0
 
 
  Dim 文字culc_reslt(16) As String
  Dim LL As Integer
 
     文字culc_reslt(2) = CStr(culc_reslt(2))  '先頭(整数部)は　0付加処理しない
    
     For LL = 3 To 16  '　0付加処理
        If culc_reslt(LL) >= 10000 Then
         文字culc_reslt(LL) = CStr(culc_reslt(LL))
        ElseIf culc_reslt(LL) < 10 Then
         文字culc_reslt(LL) = "0000" & CStr(culc_reslt(LL))
        ElseIf culc_reslt(LL) < 100 Then
         文字culc_reslt(LL) = "000" & CStr(culc_reslt(LL))
        ElseIf culc_reslt(LL) < 1000 Then
         文字culc_reslt(LL) = "00" & CStr(culc_reslt(LL))
        ElseIf culc_reslt(LL) < 10000 Then
         文字culc_reslt(LL) = "0" & CStr(culc_reslt(LL))
        End If
     Next LL
   
 
    'Exxxxの計算
      Dim Exxxx As String, Exxxx_int As Integer
     
      Exxxx_int = CLng(deci_E_符号34(1) & deci_E_body34(1)) + CLng(deci_E_符号34(2) & deci_E_body34(2)) + 桁シフトcnt - 桁シフトcnt2
        If Exxxx_int >= 1000 Then
             Exxxx = "+" & CStr(Exxxx_int)
            ElseIf Exxxx_int >= 100 Then
             Exxxx = "+0" & CStr(Exxxx_int)
            ElseIf Exxxx_int >= 10 Then
             Exxxx = "+00" & CStr(Exxxx_int)
            ElseIf Exxxx_int >= 1 Then
             Exxxx = "+000" & CStr(Exxxx_int)
            ElseIf Exxxx_int = 0 Then
             Exxxx = "+000" & CStr(Exxxx_int)
            ElseIf Exxxx_int <= -1000 Then
             Exxxx = "-" & CStr(Abs(Exxxx_int))
            ElseIf Exxxx_int <= -100 Then
             Exxxx = "-0" & CStr(Abs(Exxxx_int))
            ElseIf Exxxx_int <= -10 Then
             Exxxx = "-00" & CStr(Abs(Exxxx_int))
            ElseIf Exxxx_int <= -1 Then
             Exxxx = "-000" & CStr(Abs(Exxxx_int))
        End If

   If deci_正負_head34(1) = deci_正負_head34(2) Then
   '掛け算桁の関係で　２〜８
       ans = 文字culc_reslt(2) & "." & 文字culc_reslt(3) & 文字culc_reslt(4) & 文字culc_reslt(5) & 文字culc_reslt(6) & _
             文字culc_reslt(7) & 文字culc_reslt(8) & 文字culc_reslt(9) & "E" & Exxxx
      Else
       ans = "-" & 文字culc_reslt(2) & "." & 文字culc_reslt(3) & 文字culc_reslt(4) & 文字culc_reslt(5) & 文字culc_reslt(6) & _
                   文字culc_reslt(7) & 文字culc_reslt(8) & 文字culc_reslt(9) & "E" & Exxxx
    End If

End If


   Multipl_taby34 = ans

End Function
Function Add_taby34(ByVal bb1 As String, ByVal bb2 As String) As String
'足し算
'ans　=　bb1　+　bb2
Dim ans As String
Dim KKK As Integer, K As Integer, K2 As Integer
Dim deci_head34(2) As String
Dim deci_正負_head34(2) As String
'Dim deci_2nd_head34(2) As String
Dim deci_body34(2, 7) As String
Dim deci_E_符号34(2) As String
Dim deci_E_body34(2) As String

'以下、文字列の分解・解体
 deci_head34(1) = Left$(bb1, InStr(1, bb1, ".") - 1) ' .小数点より前
 deci_head34(2) = Left$(bb2, InStr(1, bb2, ".") - 1) ' .小数点より前
'-でない場合は強制的に　+　を付加する
 If Left$(deci_head34(1), 1) <> "-" Then
   deci_正負_head34(1) = "+"
   deci_head34(1) = "+" & deci_head34(1)
   Else
   deci_正負_head34(1) = "-"
 End If
 If Left$(deci_head34(2), 1) <> "-" Then
   deci_正負_head34(2) = "+"
   deci_head34(2) = "+" & deci_head34(2)
   Else
   deci_正負_head34(2) = "-"
 End If
 
 deci_body34(1, 1) = Mid$(bb1, InStr(bb1, ".") + 1, 5)
 deci_body34(1, 2) = Mid$(bb1, InStr(bb1, ".") + 6, 5)
 deci_body34(1, 3) = Mid$(bb1, InStr(bb1, ".") + 11, 5)
 deci_body34(1, 4) = Mid$(bb1, InStr(bb1, ".") + 16, 5)
 deci_body34(1, 5) = Mid$(bb1, InStr(bb1, ".") + 21, 5)
 deci_body34(1, 6) = Mid$(bb1, InStr(bb1, ".") + 26, 5)
 deci_body34(1, 7) = Mid$(bb1, InStr(bb1, ".") + 31, 5)
 
 deci_body34(2, 1) = Mid$(bb2, InStr(bb2, ".") + 1, 5)
 deci_body34(2, 2) = Mid$(bb2, InStr(bb2, ".") + 6, 5)
 deci_body34(2, 3) = Mid$(bb2, InStr(bb2, ".") + 11, 5)
 deci_body34(2, 4) = Mid$(bb2, InStr(bb2, ".") + 16, 5)
 deci_body34(2, 5) = Mid$(bb2, InStr(bb2, ".") + 21, 5)
 deci_body34(2, 6) = Mid$(bb2, InStr(bb2, ".") + 26, 5)
 deci_body34(2, 7) = Mid$(bb2, InStr(bb2, ".") + 31, 5)
 
 deci_E_符号34(1) = Mid$(bb1, InStr(1, bb1, "E") + 1, 1)
 deci_E_符号34(2) = Mid$(bb2, InStr(1, bb2, "E") + 1, 1)
 deci_E_body34(1) = Right$(bb1, 4)
 deci_E_body34(2) = Right$(bb2, 4)
 '解体終了
 
 '計算できるようにLong型へ変換
 Dim bb1_head As Long, bb1_body34(7) As Long
 Dim bb2_head As Long, bb2_body34(7) As Long
 
     bb1_head = CLng(deci_head34(1))
     bb2_head = CLng(deci_head34(2))
  
    For KKK = 1 To 7
     bb1_body34(KKK) = CLng(deci_body34(1, KKK))   '　LONG型へ変換　5桁（MAX：99999）なのでInt型では不可
     bb2_body34(KKK) = CLng(deci_body34(2, KKK))   '　LONG型へ変換
    Next KKK
       
 '足算の場合はまず桁の少ない方を右にシフトして桁を合わせる　　但し、絶対値
 '大きいものに小さいものを足す　小さいものの下の桁は削除する
 
  Dim 桁_差 As Integer
  '計算用のバッファ　　★Option　Base　1　の関係で整数部が　『1』
  Dim culc_buf1(8) As Long, culc_buf2(8) As Long, culc_reslt(8) As Double
      culc_buf1(1) = Abs(CLng(deci_head34(1)))         '　絶対値で入れる
      culc_buf2(1) = Abs(CLng(deci_head34(2)))         '　絶対値で入れる
      For K = 2 To 8
       culc_buf1(K) = Abs(CLng(deci_body34(1, K - 1))) '　絶対値で入れる
       culc_buf2(K) = Abs(CLng(deci_body34(2, K - 1))) '　絶対値で入れる
      Next K
           
  Dim 絶対値_大小関係 As String, 基準E As String

  If CLng(deci_E_符号34(1) & deci_E_body34(1)) > CLng(deci_E_符号34(2) & deci_E_body34(2)) Then
        絶対値_大小関係 = "Ａ＞Ｂ"
        基準E = deci_E_符号34(1) & deci_E_body34(1)  '
        桁_差 = CLng(deci_E_符号34(1) & deci_E_body34(1)) - CLng(deci_E_符号34(2) & deci_E_body34(2))
     ElseIf CLng(deci_E_符号34(1) & deci_E_body34(1)) = CLng(deci_E_符号34(2) & deci_E_body34(2)) Then
        絶対値_大小関係 = "Ａ＝Ｂ"
        基準E = deci_E_符号34(1) & deci_E_body34(1)  '
        桁_差 = 0
     Else
        絶対値_大小関係 = "Ａ＜Ｂ"
        基準E = deci_E_符号34(2) & deci_E_body34(2)  '
        桁_差 = Abs(CLng(deci_E_符号34(1) & deci_E_body34(1)) - CLng(deci_E_符号34(2) & deci_E_body34(2)))
  End If
    
  '◆　条件　：　絶対値　大小　◆
  If 絶対値_大小関係 = "Ａ＞Ｂ" Then
       
        For K = 1 To 8    '　100000進数　×　8桁
           culc_reslt(K) = CLng(deci_正負_head34(1) & "1") * culc_buf1(K)   '　結果に(絶対値の)大きな方（Ａ）を一旦入れる
        Next K
       
        '小さな方の桁シフト　buf2側
        For K2 = 1 To 桁_差
            For K = 7 To 1 Step -1
             'そのまま10で割ると最下位の桁が消えてしまう、なので、
             'ブロック内の最も下位の数字を隣のブロックへ移動する　10＾5進数
             culc_buf2(K + 1) = (culc_buf2(K) - Int(culc_buf2(K) / 10) * 10) * 10 ^ 5 + culc_buf2(K + 1)
             culc_buf2(K) = Int(culc_buf2(K) / 10) * 10  '最下位部を消す
            Next K

            For K = 1 To 8
             '全桁10で割る
             culc_buf2(K) = Round(culc_buf2(K) / 10, 0)  'Int型宣言しているのでROUND不要かもしれない
            Next K
         Next K2
        
       
        For K = 1 To 8    '　100000進数　×　8桁
              '（文字型→Long型変換しながら）小さな方（Ｂ）を加えていく
             culc_reslt(K) = culc_reslt(K) + CLng(deci_正負_head34(2) & "1") * culc_buf2(K)
        Next K
 
  ElseIf 絶対値_大小関係 = "Ａ＝Ｂ" Then
        For K = 1 To 8    '　100000進数　×　7桁
             '（文字型→Long型変換しながら） 両者を加えていく
             culc_reslt(K) = CLng(deci_正負_head34(1) & "1") * culc_buf1(K) + CLng(deci_正負_head34(2) & "1") * culc_buf2(K)
        Next K
       
  ElseIf 絶対値_大小関係 = "Ａ＜Ｂ" Then
 
        For K = 1 To 8    '　100000進数　×　8桁
           culc_reslt(K) = CLng(deci_正負_head34(2) & "1") * culc_buf2(K)   '　結果に(絶対値の)大きな方（Ｂ）を一旦入れ
        Next K
       
        '以下、小さな方（Ａ）の桁シフト　buf1側
        For K2 = 1 To 桁_差
        'そのまま10で割ると最下位の桁が消えてしまう、なので、
        'ブロック内の最も下位の数字を隣のブロックへ移動する　10＾5進数
           For K = 1 To 7
            culc_buf1(K + 1) = (culc_buf1(K) - Int(culc_buf1(K) / 10) * 10) * 10 ^ 5 + culc_buf1(K + 1)
            culc_buf1(K) = Int(culc_buf1(K) / 10) * 10  '最下位部を消す
           Next K
        '全桁10で割る
           For K = 1 To 8
             culc_buf1(K) = Round(culc_buf1(K) / 10, 0)
           Next K
        Next K2
       
        For K = 1 To 8    '　100000進数　×　7桁
         '（文字型→Long型変換しながら）小さな方（Ａ）を加えていく
             culc_reslt(K) = culc_reslt(K) + CLng(deci_正負_head34(1) & "1") * culc_buf1(K)
        Next K
   
  End If
  
 '整形処理：この段階では正負関係なく足されるので、各桁は　＋−混在状態
 'まず最上位を除く桁を＋（プラス）に統一する　・・・　（桁借りをして）
 '統一後に整数部が　-1以下であれば負の数、逆であれば正の数になることになる
 '小数点以下　+0.9999999　でも、整数部が-1なら負の数
    Dim HT As Integer
    Do
        HT = 0
        For K = 8 To 2 Step -1
         If culc_reslt(K) < 0 Then
            culc_reslt(K - 1) = culc_reslt(K - 1) - 1   '桁借り処理
            culc_reslt(K) = 10 ^ 5 + culc_reslt(K)      '桁借り処理
            HT = 1
         End If
        Next K
   
    Loop Until HT = 0  '判定HTが0になるまでやりなおし


  '最上位以外『正』化終了
 
  '借り過ぎ処理の清算
    For K = 8 To 2 Step -1
      culc_reslt(K - 1) = Int(culc_reslt(K) / 10 ^ 5) + culc_reslt(K - 1)
      culc_reslt(K) = culc_reslt(K) - Int(culc_reslt(K) / 10 ^ 5) * 10 ^ 5
    Next K


  Dim culc_reslt正負 As String
 
  If culc_reslt(1) <= -1 Then
     culc_reslt正負 = "-"
     For K = 1 To 7
        culc_reslt(K) = (-1) * culc_reslt(K)    '一旦　全桁反転させる
     Next K
    
     Do
         HT = 0
         For K = 8 To 2 Step -1
          If culc_reslt(K) < 0 Then
             culc_reslt(K - 1) = culc_reslt(K - 1) - 1    '桁借り処理
             culc_reslt(K) = 10 ^ 5 + culc_reslt(K)       '桁借り処理
             HT = 1
          End If
         Next K
     Loop Until HT = 0 '判定HTが1が立つ間はやりなおし
   
    Else
     culc_reslt正負 = "+"

     Do
         HT = 0
         For K = 8 To 2 Step -1
          If culc_reslt(K) < 0 Then
             culc_reslt(K - 1) = culc_reslt(K - 1) - 1    '桁借り処理
             culc_reslt(K) = 10 ^ 5 + culc_reslt(K)       '桁借り処理
             HT = 1
          End If
         Next K
                 
        
     Loop Until HT = 0 '判定HTが1が立つ間はやりなおし

  End If
  
  '借り過ぎ処理の清算
    For K = 8 To 2 Step -1
      culc_reslt(K - 1) = Int(culc_reslt(K) / 10 ^ 5) + culc_reslt(K - 1)
      culc_reslt(K) = culc_reslt(K) - Int(culc_reslt(K) / 10 ^ 5) * 10 ^ 5
    Next K

'桁シフト処理（全体）　・・・　最上位が0の場合シフ トしていく
  Dim 桁シフトcnt As Integer
  Do
         HT = 0
         If culc_reslt(1) = 0 Then
                
                 For K = 2 To 8
                  culc_reslt(K) = 10 * culc_reslt(K)  '　先ず全桁10倍する
                 Next K
                
                 For K = 8 To 2 Step -1
                  culc_reslt(K - 1) = culc_reslt(K - 1) + Int(culc_reslt(K) / 10 ^ 5)    '上位繰り上げ
                  culc_reslt(K) = culc_reslt(K) - Int(culc_reslt(K) / 10 ^ 5) * 10 ^ 5   '繰り上げ分を引く
                 Next K
             桁シフトcnt = 桁シフトcnt + 1
             HT = 1
         End If
           
                   
        '例外処理　全部　0の場合
          If culc_reslt(1) = 0 And culc_reslt(2) = 0 And culc_reslt(3) = 0 And culc_reslt(4) = 0 And culc_reslt(5) = 0 And _
             culc_reslt(6) = 0 And culc_reslt(7) = 0 And culc_reslt(8) = 0 Then
             Exit Do
          End If
    
  Loop Until HT = 0
   
   
    Dim E_xxxx As String
    E_xxxx = CStr(CLng(基準E) - 桁シフトcnt)
   
    If CLng(E_xxxx) >= 0 And CLng(E_xxxx) < 10 ^ 0 Then
          E_xxxx = "E+" & "0000"
        ElseIf CLng(E_xxxx) > 0 And CLng(E_xxxx) < 10 ^ 1 Then
          E_xxxx = "E+" & "000" & E_xxxx
        ElseIf CLng(E_xxxx) > 0 And CLng(E_xxxx) < 10 ^ 2 Then
          E_xxxx = "E+" & "00" & E_xxxx
        ElseIf CLng(E_xxxx) > 0 And CLng(E_xxxx) < 10 ^ 3 Then
          E_xxxx = "E+" & "0" & E_xxxx
        ElseIf CLng(E_xxxx) > 0 And CLng(E_xxxx) < 10 ^ 4 Then
          E_xxxx = "E+" & "" & E_xxxx
        ElseIf CLng(E_xxxx) < 0 And Abs(CLng(E_xxxx)) < 10 ^ 0 Then
          E_xxxx = "E-" & "0000" & E_xxxx
        ElseIf CLng(E_xxxx) < 0 And Abs(CLng(E_xxxx)) < 10 ^ 1 Then
          E_xxxx = "E-" & "000" & Right$(E_xxxx, 1)
        ElseIf CLng(E_xxxx) < 0 And Abs(CLng(E_xxxx)) < 10 ^ 2 Then
          E_xxxx = "E-" & "00" & Right$(E_xxxx, 2)
        ElseIf CLng(E_xxxx) < 0 And Abs(CLng(E_xxxx)) < 10 ^ 3 Then
          E_xxxx = "E-" & "0" & Right$(E_xxxx, 3)
        ElseIf CLng(E_xxxx) < 0 And Abs(CLng(E_xxxx)) < 10 ^ 4 Then
          E_xxxx = "E-" & "" & Right$(E_xxxx, 4)
      End If
   
    '例外処理　全部　0の場合
       If culc_reslt(1) = 0 And culc_reslt(2) = 0 And culc_reslt(3) = 0 And culc_reslt(4) = 0 And culc_reslt(5) = 0 And _
          culc_reslt(6) = 0 And culc_reslt(7) = 0 And culc_reslt(8) = 0 Then
          E_xxxx = "E+0000"
       End If
   
    ' 文字列への変換
    Dim 文字列culc_reslt(8) As String
    文字列culc_reslt(1) = CStr(culc_reslt(1))
    For K = 2 To 8
      If culc_reslt(K) < 10 ^ 1 Then
        文字列culc_reslt(K) = "0000" & CStr(culc_reslt(K))
        ElseIf culc_reslt(K) < 10 ^ 2 Then
        文字列culc_reslt(K) = "000" & CStr(culc_reslt(K))
        ElseIf culc_reslt(K) < 10 ^ 3 Then
        文字列culc_reslt(K) = "00" & CStr(culc_reslt(K))
        ElseIf culc_reslt(K) < 10 ^ 4 Then
        文字列culc_reslt(K) = "0" & CStr(culc_reslt(K))
        ElseIf culc_reslt(K) < 10 ^ 5 Then
        文字列culc_reslt(K) = "" & CStr(culc_reslt(K))
      End If
    Next K
   
    If culc_reslt正負 = "-" Then
      ans = "-" & 文字列culc_reslt(1) & "."
    Else
      ans = "" & 文字列culc_reslt(1) & "."
    End If
   
    For K = 2 To 8
      ans = ans & 文字列culc_reslt(K)
    Next K
    ans = ans & E_xxxx

    Add_taby34 = ans

End Function
Function Subtrac_taby34(ByVal bb1 As String, ByVal bb2 As String) As String
'引き算
Dim ans0 As String
Dim bb2_rev As String

If Left$(bb2, 1) <> "-" Then
     bb2_rev = "-" & bb2                  '　”−”を付加
    ElseIf Left$(bb2, 1) = "-" Then
     bb2_rev = Right$(bb2, Len(bb2) - 1)  '右側から数えて１文字削除
End If

  ans0 = Add_taby34(bb1, bb2_rev)

  Subtrac_taby34 = ans0

End Function
Function 文字列分解_正負34(ByVal xx As String) As String
Dim ans00 As String

'正負の調査
    If InStr(1, xx, "-") > 0 Then
      ans00 = "-"
    Else
      ans00 = "+"
    End If

    文字列分解_正負34 = ans00

End Function
Function フォーマット調査34(ByVal aaa As String) As Boolean

Dim 結果1 As Boolean
Dim x1, x2, x3, x4, x5 As Integer

'  値 As String    '形式　-0.00000・・(34桁)・・000E+0000


'=39 +5 文字以下であること
If Len(aaa) > 39 + 5 Then
    MsgBox "文字数=　" & Len(aaa) & "　文字数が長すぎです(43文字〜44文字)"
      x1 = 0
    Stop
    Else
      x1 = 1
End If
     
     
'38文字以下であること
If Len(aaa) < 43 Then
    MsgBox "文字数=　" & Len(aaa) & "　文字数が短すぎです(38文字〜39文字)"
     x2 = 0
    Stop
    Else
     x2 = 1
End If

'38〜39文字目にEが入っていること
If InStr(aaa, "E") <> 38 And InStr(aaa, "E") <> 39 Then
    MsgBox "Eの位置が不正です"
    x3 = 0
    Stop
    Else
      x3 = 1
End If

'39〜40文字目に　+　か　-　記号が入っているこ と
If InStrRev(aaa, "+") <> 39 And InStrRev(aaa, "+") <> 40 And InStrRev(aaa, "-") <> 39 And InStrRev(aaa, "-") <> 40 Then
    MsgBox "べきの正負符号の位置が不正です"
    x4 = 0
    Stop
Else
       x4 = 1
End If

'小数点があること
If InStr(1, aaa, ".") <= 1 Then
    MsgBox "小数点の位置が不正です"
    x5 = 0
    Stop
     Else
      x5 = 1
End If


If x1 = 1 And x2 = 1 And x3 = 1 And x4 = 1 And x5 = 1 Then
      結果1 = True
End If

    フォーマット調査34 = 結果1
   
End Function





 




Math TOP