エクセルVBAの標準モジュールに置くと使える。
‘ Textcalc は長いので、egに変更 2008.02.07 By Norio
‘ —内容—
‘ 計算に関係無い文字を無視する
‘ ２行にまたがる計算を行う
‘ 数字、演算記号を含むメモ書きは、必ずカッコで閉じる
‘ =eg(セル番号）で計算
‘ =egs(セル番号,n)で四捨伍入計算を行う
‘ =egw(セル番号1,セル番号2）で２行計算
‘ =egws(セル番号1,セル番号2,n)で２行四捨伍入計算を行う
‘ —
‘ 著作権はpeace氏に帰属します
‘ Textcalc Version1.30 (C)1996-2000, peace
‘
Option Explicit
Private Token As String
Private A1 As String
Private TokenType As Integer ‘1:DELIMITER 2:NUMBER 3:FUNCTION
Private S As String
Private SLen As Integer
Private K, K1, N1, N2, N3 As Integer
Private GP As Integer
Private KAKKO As Integer
Const MAE As String = “.0123456789)”
Const USIRO As String = “±⇒〆∥￣＿＼｜∃♂♀√.0123456789(”
Const DELIMITA As String = “+-*/()^”
Const NUMBER As String = “0123456789”
Const OKMOJI As String = “±⇒〆∥￣＿＼｜∃♂♀√^()*/+-.0123456789”
Const RAD As Double = 57.2957795130823
‘ 関数のエントリポイント
Function eg(S2 As String) As Double ‘textcalからegに変更
S2 = StrConv(S2, vbNarrow)
S2 = StrConv(S2, vbLowerCase)
S2 = Application.Substitute(S2, ” “, “”)
S2 = Application.Substitute(S2, “π”, “3.14159265358979”)
S2 = Application.Substitute(S2, “pi”, “3.14159265358979”)
S2 = Application.Substitute(S2, “rad”, “57.2957795130823”)
S2 = Application.Substitute(S2, “{“, “(“)
S2 = Application.Substitute(S2, “}”, “)”)
S2 = Application.Substitute(S2, “[“, “(“)
S2 = Application.Substitute(S2, “]”, “)”)
S2 = Application.Substitute(S2, “〔”, “(“)
S2 = Application.Substitute(S2, “〕”, “)”)
S2 = Application.Substitute(S2, “【”, “(“)
S2 = Application.Substitute(S2, “】”, “)”)
S2 = Application.Substitute(S2, “×”, “*”)
S2 = Application.Substitute(S2, “÷”, “/”)
””’No*,第*を削除する””’
S2 = Application.Substitute(S2, “J”, “”)
S2 = Application.Substitute(S2, “no.”, “J”)
S2 = Application.Substitute(S2, “no、”, “J”)
S2 = Application.Substitute(S2, “no”, “J”)
S2 = Application.Substitute(S2, “第”, “J”)
S2 = Application.Substitute(S2, “※”, “J”)
N2 = 0
N3 = 0
For K = 1 To Len(S2) ‘Jの数を数える
If Mid(S2, K, 1) = “J” Then N2 = N2 + 1
Next
Do While N2 > 0 ‘”J”と次の”J”又は”)”の文字位置を求める
N1 = InStr(S2, “J”)
If InStr(N1 + 1, S2, “J”) > 0 And InStr(N1 + 1, S2, “J”) <= InStr(N1 + 1, S2, “)”) _
Then N3 = InStr(N1 + 1, S2, “J”) Else N3 = InStr(N1 + 1, S2, “)”)
If InStr(N1 + 1, S2, “J”) = 0 Then N3 = InStr(N1 + 1, S2, “)”)
A1 = “”
For K = 1 To Len(S2) ‘”J”と次の”J”又は”)”の間の文字を削除
If K < N1 Or K >= N3 Then A1 = A1 + Mid(S2, K, 1)
Next K
S2 = A1
N2 = N2 – 1
Loop
””’
S2 = Application.Substitute(S2, “±”, “”) ‘下で使用する文字を削除しておく
S2 = Application.Substitute(S2, “⇒”, “”)
S2 = Application.Substitute(S2, “〆”, “”)
S2 = Application.Substitute(S2, “∥”, “”)
S2 = Application.Substitute(S2, “￣”, “”)
S2 = Application.Substitute(S2, “＿”, “”)
S2 = Application.Substitute(S2, “＼”, “”)
S2 = Application.Substitute(S2, “｜”, “”)
S2 = Application.Substitute(S2, “∃”, “”)
S2 = Application.Substitute(S2, “♂”, “”)
S2 = Application.Substitute(S2, “♀”, “”)
S2 = Application.Substitute(S2, “asin”, “±”) ‘予約語を特殊文字に置き換える
S2 = Application.Substitute(S2, “acos”, “⇒”)
S2 = Application.Substitute(S2, “atan”, “〆”)
S2 = Application.Substitute(S2, “sin”, “∥”)
S2 = Application.Substitute(S2, “cos”, “￣”)
S2 = Application.Substitute(S2, “tan”, “＿”)
S2 = Application.Substitute(S2, “abs”, “＼”)
S2 = Application.Substitute(S2, “int”, “｜”)
S2 = Application.Substitute(S2, “exp”, “∃”)
S2 = Application.Substitute(S2, “log”, “♂”)
S2 = Application.Substitute(S2, “ln”, “♀”)
S2 = Application.Substitute(S2, “/m3”, “”) ‘/m3,/m2,/m,m2,m3,m4を削除
S2 = Application.Substitute(S2, “/m2”, “”)
S2 = Application.Substitute(S2, “/m”, “”)
S2 = Application.Substitute(S2, “m2”, “”)
S2 = Application.Substitute(S2, “m3”, “”)
S2 = Application.Substitute(S2, “m4”, “”)
””’予約語、数字、演算記号以外を削除する””’
A1 = “”
For K = 1 To Len(S2)
For K1 = 1 To Len(OKMOJI)
If Mid(S2, K, 1) = Mid(OKMOJI, K1, 1) Then A1 = A1 + Mid(S2, K, 1)
Next K1
Next K
S2 = A1
S2 = Application.Substitute(S2, “()”, “”)
””’memoの削除（memoが最初にある場合）””’
If Mid(S2, 1, 1) <> “(” Then GoTo line1
N3 = 0
For K = 1 To Len(S2)
For K1 = 1 To Len(USIRO)
If Mid(S2, K, 1) = “)” And Mid(S2, K + 1, 1) = Mid(USIRO, K1, 1) Then N3 = K
Next
Next
A1 = “”
For K = 1 To Len(S2) ””’memoの”(“から”)”までの文字を削除
If K > N3 Then A1 = A1 + Mid(S2, K, 1)
Next K
S2 = A1
””’memoの削除（memoが中間又は最後にある場合）””’
line1:
A1 = “”
N1 = 0
N2 = 0
For K = 2 To Len(S2) ””’memoの数を数える
For K1 = 1 To Len(MAE)
If Mid(S2, K, 1) = “(” And Mid(S2, K – 1, 1) = Mid(MAE, K1, 1) Then N2 = N2 + 1
Next
Next
Do While N2 > 0
For K = 2 To Len(S2)
For K1 = 1 To Len(MAE)
If Mid(S2, K, 1) = “(” And Mid(S2, K – 1, 1) = Mid(MAE, K1, 1) Then N1 = K
N3 = InStr(N1 + 1, S2, “)”)
Next
Next
A1 = “”
For K = 1 To Len(S2) ””’memoの”(“から”)”までの文字を削除
If K < N1 Or K > N3 Then A1 = A1 + Mid(S2, K, 1)
Next K
S2 = A1
N2 = N2 – 1
Loop
””’
S2 = Application.Substitute(S2, “±”, “asin”) ‘予約語を元に戻す
S2 = Application.Substitute(S2, “⇒”, “acos”)
S2 = Application.Substitute(S2, “〆”, “atan”)
S2 = Application.Substitute(S2, “∥”, “sin”)
S2 = Application.Substitute(S2, “￣”, “cos”)
S2 = Application.Substitute(S2, “＿”, “tan”)
S2 = Application.Substitute(S2, “＼”, “abs”)
S2 = Application.Substitute(S2, “｜”, “int”)
S2 = Application.Substitute(S2, “∃”, “exp”)
S2 = Application.Substitute(S2, “♂”, “log”)
S2 = Application.Substitute(S2, “♀”, “ln”)
S2 = Application.Substitute(S2, “√”, “sqrt”)
KAKKO = 0
GP = 1
S = S2
SLen = Len(S)
GetToken
eg = sub1(0#)
If (KAKKO <> 0) Then
MsgBox “括弧の指定に誤りがあります。” _
, vbOKOnly + vbExclamation, “EG関数”
eg = 1 / 0 ‘textcalcからegに変更
End If
End Function
‘ 加算・減算の処理
Function sub1(Value As Double) As Double
Dim Value2 As Double
Dim Token2 As String
Value = sub2(Value)
While Token = “+” Or Token = “-”
Token2 = Token
GetToken
Value2 = sub2(Value2)
Select Case Token2
Case “+”
Value = Value + Value2
Case “-”
Value = Value – Value2
End Select
Wend
sub1 = Value
End Function
‘ 乗算、除算の処理
Function sub2(Value As Double) As Double
Dim Value2 As Double
Dim Token2 As String
Value = sub3(Value)
While Token = “*” Or Token = “/”
Token2 = Token
GetToken
Value2 = sub3(Value2)
Select Case Token2
Case “*”
Value = Value * Value2
Case “/”
Value = Value / Value2
End Select
Wend
sub2 = Value
End Function
‘ べき乗の処理
Function sub3(Value As Double) As Double
Dim Value2 As Double
Dim Token2 As String
Value = sub4(Value)
While Token = “^”
Token2 = Token
GetToken
Value2 = sub4(Value2)
Select Case Token2
Case “^”
Value = Value ^ Value2
End Select
Wend
sub3 = Value
End Function
‘ 単項演算子の処理
Function sub4(Value As Double) As Double
Dim Token2 As String
If Token = “+” Or Token = “-” Then
Token2 = Token
GetToken
End If
Value = sub5(Value)
If Token2 = “-” Then
Value = -Value
End If
sub4 = Value
End Function
‘ 括弧の処理
Function sub5(Value As Double) As Double
If Token = “(” Then
GetToken
Value = sub1(Value)
GetToken
Else
Value = Atom()
End If
sub5 = Value
End Function
‘ 数値の処理
Function Atom() As Double
Dim temp As String
Dim i As Integer
Dim Value2 As Double
If TokenType = 3 Then
Atom = Func(Token)
ElseIf TokenType = 2 Then
Atom = Val(Token)
GetToken
End If
End Function
‘算術関数の処理
Function Func(str As String) As Double
Dim Value2 As Double
Dim str2 As Double
Select Case str
Case “sin”
GetToken
Value2 = sub4(Value2)
Func = Sin(Value2 / RAD)
Case “cos”
GetToken
Value2 = sub4(Value2)
Func = Cos(Value2 / RAD)
Case “tan”
GetToken
Value2 = sub4(Value2)
Func = Tan(Value2 / RAD)
Case “asin”
GetToken
Value2 = sub4(Value2)
Func = WorksheetFunction.Asin(Value2) * RAD
Case “acos”
GetToken
Value2 = sub4(Value2)
Func = WorksheetFunction.Acos(Value2) * RAD
Case “atan”
GetToken
Value2 = sub4(Value2)
Func = Atn(Value2) * RAD
Case “abs”
GetToken
Value2 = sub4(Value2)
Func = Abs(Value2)
Case “int”
GetToken
Value2 = sub4(Value2)
Func = Int(Value2)
Case “exp”
GetToken
Value2 = sub4(Value2)
Func = Exp(Value2)
Case “log”
GetToken
Value2 = sub4(Value2)
Func = Log(Value2) / Log(10#) ‘”/ Log(10#)”を追加
Case “ln” ‘追加
GetToken ‘追加
Value2 = sub4(Value2) ‘追加
Func = Log(Value2) ‘追加
Case “sqrt”
GetToken
Value2 = sub4(Value2)
Func = Sqr(Value2)
Case Else
MsgBox “関数 ” + str + ” は定義されていません。” _
, vbOKOnly + vbExclamation, “EG関数”
Func = 1 / 0
End Select
End Function
‘ トークンの切出し
Function GetToken()
Dim i As Integer
If GP > SLen Then
Token = “”
Exit Function
End If
If InStr(DELIMITA, Mid(S, GP, 1)) <> 0 Then
Token = Mid(S, GP, 1)
TokenType = 1
GP = GP + 1
If Token = “(” Then ‘括弧のチェック
KAKKO = KAKKO + 1
ElseIf Token = “)” Then
KAKKO = KAKKO – 1
End If
ElseIf InStr(NUMBER, Mid(S, GP, 1)) <> 0 Then
For i = GP To SLen
If InStr(DELIMITA, Mid(S, i, 1)) <> 0 Then
Exit For
End If
Next
Token = Mid(S, GP, i – GP)
TokenType = 2
GP = i
Else
For i = GP To SLen
If InStr(DELIMITA, Mid(S, i, 1)) <> 0 Then
Exit For
End If
Next
Token = Mid(S, GP, i – GP)
TokenType = 3
GP = i
End If
End Function
‘ 四捨五入計算
Function egs(S2 As String, kurai As Integer) As Double
egs = Application.Round(eg(S2), kurai)
End Function
‘ ２行の計算
Function egw(G1 As String, G2 As String) As Double
egw = eg(G1 + G2)
End Function
‘ ２行四捨五入計算
Function egws(G1 As String, G2 As String, kurai As Integer) As Double
egws = Application.Round(eg(G1 + G2), kurai)
End Function
コメント