◆エクセル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