画期的なVBAを見つけてしまった＾＾目から鱗だよ！
エクセル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 ExplicitPrivate Token As StringPrivate A1 As StringPrivate TokenType As Integer '1:DELIMITER 2:NUMBER 3:FUNCTIONPrivate S As StringPrivate SLen As IntegerPrivate K, K1, N1, N2, N3 As IntegerPrivate GP As IntegerPrivate KAKKO As IntegerConst 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 = 0N3 = 0For K = 1 To Len(S2) 'Jの数を数えるIf Mid(S2, K, 1) = "J" Then N2 = N2 + 1NextDo 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 KS2 = A1N2 = N2 - 1Loop'''''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 K1Next KS2 = A1S2 = Application.Substitute(S2, "()", "")'''''memoの削除（memoが最初にある場合）'''''If Mid(S2, 1, 1) <> "(" Then GoTo line1N3 = 0For 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 = KNextNextA1 = ""For K = 1 To Len(S2) '''''memoの"("から")"までの文字を削除If K > N3 Then A1 = A1 + Mid(S2, K, 1)Next KS2 = A1'''''memoの削除（memoが中間又は最後にある場合）'''''line1:A1 = ""N1 = 0N2 = 0For 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 + 1NextNextDo While N2 > 0For 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 = KN3 = InStr(N1 + 1, S2, ")")NextNextA1 = ""For K = 1 To Len(S2) '''''memoの"("から")"までの文字を削除If K < N1 Or K > N3 Then A1 = A1 + Mid(S2, K, 1)Next KS2 = A1N2 = N2 - 1Loop'''''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 = 0GP = 1S = S2SLen = Len(S)GetTokeneg = sub1(0#)If (KAKKO <> 0) ThenMsgBox "括弧の指定に誤りがあります。" _, vbOKOnly + vbExclamation, "EG関数"eg = 1 / 0 'textcalcからegに変更End IfEnd Function' 加算・減算の処理Function sub1(Value As Double) As DoubleDim Value2 As DoubleDim Token2 As StringValue = sub2(Value)While Token = "+" Or Token = "-"Token2 = TokenGetTokenValue2 = sub2(Value2)Select Case Token2Case "+"Value = Value + Value2Case "-"Value = Value - Value2End SelectWendsub1 = ValueEnd Function' 乗算、除算の処理Function sub2(Value As Double) As DoubleDim Value2 As DoubleDim Token2 As StringValue = sub3(Value)While Token = "*" Or Token = "/"Token2 = TokenGetTokenValue2 = sub3(Value2)Select Case Token2Case "*"Value = Value * Value2Case "/"Value = Value / Value2End SelectWendsub2 = ValueEnd Function' べき乗の処理Function sub3(Value As Double) As DoubleDim Value2 As DoubleDim Token2 As StringValue = sub4(Value)While Token = "^"Token2 = TokenGetTokenValue2 = sub4(Value2)Select Case Token2Case "^"Value = Value ^ Value2End SelectWendsub3 = ValueEnd Function' 単項演算子の処理Function sub4(Value As Double) As DoubleDim Token2 As StringIf Token = "+" Or Token = "-" ThenToken2 = TokenGetTokenEnd IfValue = sub5(Value)If Token2 = "-" ThenValue = -ValueEnd Ifsub4 = ValueEnd Function' 括弧の処理Function sub5(Value As Double) As DoubleIf Token = "(" ThenGetTokenValue = sub1(Value)GetTokenElseValue = Atom()End Ifsub5 = ValueEnd Function' 数値の処理Function Atom() As DoubleDim temp As StringDim i As IntegerDim Value2 As DoubleIf TokenType = 3 ThenAtom = Func(Token)ElseIf TokenType = 2 ThenAtom = Val(Token)GetTokenEnd IfEnd Function'算術関数の処理Function Func(str As String) As DoubleDim Value2 As DoubleDim str2 As DoubleSelect Case strCase "sin"GetTokenValue2 = sub4(Value2)Func = Sin(Value2 / RAD)Case "cos"GetTokenValue2 = sub4(Value2)Func = Cos(Value2 / RAD)Case "tan"GetTokenValue2 = sub4(Value2)Func = Tan(Value2 / RAD)Case "asin"GetTokenValue2 = sub4(Value2)Func = WorksheetFunction.Asin(Value2) * RADCase "acos"GetTokenValue2 = sub4(Value2)Func = WorksheetFunction.Acos(Value2) * RADCase "atan"GetTokenValue2 = sub4(Value2)Func = Atn(Value2) * RADCase "abs"GetTokenValue2 = sub4(Value2)Func = Abs(Value2)Case "int"GetTokenValue2 = sub4(Value2)Func = Int(Value2)Case "exp"GetTokenValue2 = sub4(Value2)Func = Exp(Value2)Case "log"GetTokenValue2 = sub4(Value2)Func = Log(Value2) / Log(10#) '"/ Log(10#)"を追加Case "ln" '追加GetToken '追加Value2 = sub4(Value2) '追加Func = Log(Value2) '追加Case "sqrt"GetTokenValue2 = sub4(Value2)Func = Sqr(Value2)Case ElseMsgBox "関数 " + str + " は定義されていません。" _, vbOKOnly + vbExclamation, "EG関数"Func = 1 / 0End SelectEnd Function' トークンの切出しFunction GetToken()Dim i As IntegerIf GP > SLen ThenToken = ""Exit FunctionEnd IfIf InStr(DELIMITA, Mid(S, GP, 1)) <> 0 ThenToken = Mid(S, GP, 1)TokenType = 1GP = GP + 1If Token = "(" Then '括弧のチェックKAKKO = KAKKO + 1ElseIf Token = ")" ThenKAKKO = KAKKO - 1End IfElseIf InStr(NUMBER, Mid(S, GP, 1)) <> 0 ThenFor i = GP To SLenIf InStr(DELIMITA, Mid(S, i, 1)) <> 0 ThenExit ForEnd IfNextToken = Mid(S, GP, i - GP)TokenType = 2GP = iElseFor i = GP To SLenIf InStr(DELIMITA, Mid(S, i, 1)) <> 0 ThenExit ForEnd IfNextToken = Mid(S, GP, i - GP)TokenType = 3GP = iEnd IfEnd Function' 四捨五入計算Function egs(S2 As String, kurai As Integer) As Doubleegs = Application.Round(eg(S2), kurai)End Function' ２行の計算Function egw(G1 As String, G2 As String) As Doubleegw = eg(G1 + G2)End Function' ２行四捨五入計算Function egws(G1 As String, G2 As String, kurai As Integer) As Doubleegws = Application.Round(eg(G1 + G2), kurai)End Function
出産・子育て
ファッション
美容・コスメ
健康・ダイエット
生活・インテリア
料理・食べ物
ドリンク・お酒
ペット
趣味・ゲーム
映画・ＴＶ
音楽
読書・コミック
旅行・海外情報
園芸
スポーツ
アウトドア・釣り
車・バイク
パソコン・家電
そのほか
すべてのジャンル
