[[20030902013410]]　『マクロ[tfcalc]について』（あみちん）　ページの最後に飛ぶ

『マクロ[tfcalc]について』（あみちん）

あるセルに文字（例えば　５×３÷２）で入力しても、計算結果を示してくれる「tfcalc」というマクロの作り方をご教示下さい。

下記に例を示します。

Ａ１セルに　５×３÷２（半角でも全角でも、*+-/　×＋－÷　のどれでも対応）

Ｂ１セルに　=tfcalc(A1)

この場合、Ｂ１には、7.5　と表示。

※Ａ１セルの入力値を変更するとＢ１セルの値は自動で計算されるというもの。

 これのことですか？入手するのではなく、同じ機能のものを作りたいということですか？(YS)
http://www.showacd.co.jp/info/info_0112.htm

 =tfcalc(A1)といった表現は無理ですが、提示されている内容と同様の機能であれば
 以下のようにすれば良いと思います。(INA)

 ＜シートモジュール＞
 Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = Range("A1").Address Then
    Call tfcalc
   End If
 End Sub

 ＜標準モジュール＞
 Sub tfcalc()
  With Range("A1")
    .Replace What:="×", Replacement:="*", LookAt:=xlPart
    .Replace What:="÷", Replacement:="/", LookAt:=xlPart
    .Replace What:="＋", Replacement:="+", LookAt:=xlPart
    .Replace What:="－", Replacement:="-", LookAt:=xlPart
  End With
     Range("B1").Formula = "=" & Range("A1").Value
 End Sub

 この解答はあみちんさんの問いの半分しか消化でけてえしまへんけど、このままスレが
 沈んでいくんは忍びないんで私の分かる範囲でお答えしときますわ。

 ModuleのGeneral Declarations（真新しいモジュールの１番上の行）に
 Function tfcalc(data)
     data = StrConv(data, vbNarrow)’この欄半角に直す作業
    tfcalc = data * 5　　　　　　　’Ａ１の数値に５をかける作業　　
 End Function
 コレで一応ユーザー関数の出来上がりで、Ｂ１に=tfcalc(A1)と入力すればＯＫですわ

 それはよろしおまんねんけど、さあ、文字列で入力された式を数式に変換して評価する
 っちゅう関数が、悔しい事に私にゃ分かりまへんねん。
 まあ、こうやってスレ上げとったら上級者の目ぇに止まって教えてくれるやもしれまへ
 んさかい、もうちょっと待ってみまひょか。
 　　　（おいぼれ弥太郎）

ご意見ありがとうございます。

実は、全角文字の括弧から小数点から数字から全てに対応しています。

誰が作ったかわかりませんが、そのファイルは手元にあります。

ただ、モジュールの見方がわかりません。
（ツール→マクロでは、それらしいものは存在しません）

どなたかご教示ください。

こんな初心的質問で申し訳ありません。

（あみちん）

 はい、はい。
 Alt+F11でモジュールが開きます。左の列にModule1～順番に並んでると思いますさかい
 片っ端から開いてみておくんなはれ。
 もしModuleが見えなかったら標準モジュールっちゅうて書いてある所をクリックしてみ
 ておくんなはれ。左の列にそんなんがなかったら　Ctrl+Rを押してみて下さい。
 キッとええお宝が眠ってまっせぇ。
 そこでお願いでんねんけど、そのお宝私にも拝ませて頂けまへんやろか。大いに勉強に
 なりますさかいな、お待ちしてますわ。
 　　　（おいぼれ弥太郎）

ありがとうございます。見れました。

私にはよくわかりませんが、

'
Option Explicit

Private Token As String

Private TokenType As Integer '1:DELIMITER 2:NUMBER 3:FUNCTION

Private S As String

Private SLen As Integer

Private GP As Integer

Private KAKKO As Integer

Const DELIMITA As String = "+-*/()^"

Const NUMBER As String = "0123456789"

Const RAD As Double = 57.2957795130823

' 関数のエントリポイント
Function TFcalc(T2 As String) As Double

    T2 = StrConv(T2, vbNarrow)
    T2 = StrConv(T2, vbLowerCase)
    T2 = Application.Substitute(T2, " ", "")
    T2 = Application.Substitute(T2, "×", "*")
    T2 = Application.Substitute(T2, "ﾗ", "*")
    T2 = Application.Substitute(T2, "÷", "/")
    T2 = Application.Substitute(T2, "=", "")
    T2 = Application.Substitute(T2, "√", "sqrt")
    T2 = Application.Substitute(T2, ",", "")
    T2 = Application.Substitute(T2, "{", "(")
    T2 = Application.Substitute(T2, "}", ")")
    T2 = Application.Substitute(T2, "[", "(")
    T2 = Application.Substitute(T2, "]", ")")
    T2 = Application.Substitute(T2, "π", "3.14159265358979")
    T2 = Application.Substitute(T2, "pi", "3.14159265358979")
    T2 = Application.Substitute(T2, "rad", "57.2957795130823")

    KAKKO = 0
    GP = 1
    S = T2
    SLen = Len(S)

    GetToken
    TFcalc = sub1(0#)
    If (KAKKO <> 0) Then
        MsgBox "カッコの指定に誤りがあります。" _
        , vbOKOnly + vbExclamation, "TFcalc"
        TFcalc = 1 / 0
    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)
        Case "sqrt"
            GetToken
            Value2 = sub4(Value2)
            Func = Sqr(Value2)
        Case Else
            MsgBox "関数 " + str + " は定義されていません." _
            , vbOKOnly + vbExclamation, "TFcalc"
            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

（あみちん）

 ヒェ～ッ！すごいっ！！！
 あみちんさん、ええ宝モン見つけてくれはりましたなぁ。イヤ～、嬉しい嬉しい！
 感謝感激、雨....ですわ、えぇえぇ。
 なんや今年１番の大儲けした気分でっせ、ホンマに。
 あみちんさんのご質問に似たようなのがなんぼかおましたけど、ココまで作業するの
 んははじめてみたいですわ、えぇ。

 まだようまわしてまへんけど、=tfcalc(A1)で簡単に答え出すには裏方であれだけのコ
 ードが働いてまんねんなぁ。この方、相当の使い手と見受けられますわ、うんうん。

 何とかお力添えに（なれへんなれへん）と思うてカキコしましたんやけど、とてつもな
 いお礼を頂きまして甚だ恐縮しておりますわ、えぇ。INAさんも小躍りして喜んでまっ
 しゃろさかい、彼の分も一緒にお礼言うときます。おおきに、おおきに。
 　　　　（おいぼれ弥太郎）

コメント返信：

[ 一覧(最新更新順) ]

[[20030902013410]] 『マクロ[tfcalc]について』（あみちん） ページの最後に飛ぶ

[[20030902013410]]　『マクロ[tfcalc]について』（あみちん）　ページの最後に飛ぶ