ユーザー定義関数について質問します。２

質問

数日前にここでユーザー定義関数」について教えてもらいました。
http://oshiete1.goo.ne.jp/qa2821529.html
指定セル内に表示されている計算式の解を出すものです。
上付き文字を指数として認識できるように考えてもらいました。
その時は問題なく使えると思って質問を締め切ってしまいましたが
不具合があるようですので対処法を教えてください。
状況としては、
2×3^2 （＾2は上付き文字で2）→ＯＫ
3^2×2 ( 〃 ) →32×2と認識してしまう。
上付き文字より右に式が続くと指数扱いにならないようです。
私の検証不足で二度手間になり申し訳ありません。
よろしくお願いします。

回答No.5

Wendy02 · ベストアンサー

これは、直接の回答ではありません。

一応、このユーザー定義関数の問題になった部分--二つの上付き文字を算出できない--場合の理由を、記録として残しておきます。

[累乗は、本来は、書式上付き文字]

この場合の、Font のSuperscript は、
F =False, T = True, N =Null

2×2^2　　　　　　　 NNNT
2^1×2　　　　　　　 NNFF　　
2×2^2×2　　　　　　NNNNFF
2×2^2×3^2　　　　　NNNNNNT　　×
2^2×2^2×3^3　　　　NNNNNNNT　　×

二つある場合は取得できません。（一体、どことどこに上付き文字があるのかは、これでは分かりません）少なくとも、この方法では、無理だということが分かります。

'検査用マクロ
Sub TEST_Superscript()
Dim rng As Range
Dim i As Long
Dim buf As Variant
Dim k As String
Set rng = ActiveCell
For i = 1 To Len(rng.Value)
　If IsNull(rng.Characters(i).Font.Superscript) Then
　　buf = "N" 'Null
　Else
　'True / False
　　buf = Left(CStr(rng.Characters(i).Font.Superscript), 1)
　End If
　　k = k & buf
　　buf = ""
Next i
　 rng.Offset(, 1).Value = k
End Sub

回答No.4

Wendy02

こんにちは。

>指数が2回出る場合、エラー表示せず、誤計算するようです。
エラーを出すようにはしたつもりだったのですが、エラーが出ないようです。

それは、最初にも書いたように、現在の方法では、どんなにやっても、事実上不可能です。Rangeオブジェクトのフォントプロパティの中の上付き文字の判定は、一回限りだと思います。

少なくとも、私の今のVBAの能力では、無理だと思います。私以外の人で出来る方がいらっしゃるかもしれませんが、それは、また新たにお願いします。これ以外の問題でありましたら、直すことは可能です。

お礼

返答ありがとうございます。
検証のためしばらくこのままで使わせてもらいます。
もし何かあれば報告します。その時はまた見てください。
ありがとうございました。

回答No.3

Wendy02

こんにちは。

サブルーチンはそのままです。T2C側だけを入れ替えてみてください。
これで、しばらく様子をみていただけますか？

Public Function T2C(セル As Variant, Optional pwrs As Integer = 1) As Variant
'goo_no.2848879 20.03.07_v.0.4
Dim strArg As String
Dim ssflg As Boolean
Dim rng As Range
Dim TOp As Variant
Dim Op As Variant
Dim i As Integer
Dim j As Integer
Dim buf As String
Dim k As Integer
'pwrs = 1 '累乗の桁

'√は、必ず、最後にしてください。
'本来は、＋,－は、文字列を半角にしてしまうので不要です。
Const TXTOPERAND As String = "[,],{,},＋,－,×,÷,π,√"
Const OPERAND As String = "(,),(,),+,-,*,/,PI(),SQRT"

TOp = Split(TXTOPERAND, ",")
Op = Split(OPERAND, ",")

'Altered Two Byte Argument to One Byte Variable
Set rng = セル

If StrComp(TypeName(rng), "RANGE", vbTextCompare) <> 0 Then Exit Function
If VarType(rng) = vbDouble Then T2C = rng.Value: Exit Function
'SuperScript Checking
　If Not rng.Characters(1).Font.Superscript = Null Then
　　　　For i = 1 To Len(rng.Value)
　　　　　　If rng.Characters(i).Font.Superscript = True And ssflg = False Then
　　　　　　　　strArg = strArg & "^" & Mid$(rng.Value, i, 1)
　　　　　　　　ssflg = True
　　　　　　Else
　　　　　　　　strArg = strArg & Mid$(rng.Value, i, 1)
　　　　　　End If
　　　　Next i
　　Else
　　　　For j = 1 To Len(rng.Value)
　　　　　　If rng.Characters(j).Font.Superscript = False And ssflg = False Then
　　　　　　　　strArg = strArg & Mid$(rng.Value, j, 1)
　　　　　　　　If buf <> "" Then ssflg = True
　　　　　　ElseIf IsNull(rng.Characters(j).Font.Superscript) And ssflg = False Then
　　　　　　　　buf = buf & Mid$(rng.Value, j, 1)
　　　　　　ElseIf rng.Characters(j).Font.Superscript Then
　　　　　　　　If j = Len(rng.Value) - (pwrs - 1) Then
　　　　　　　　　 strArg = buf & "^" & Mid$(rng.Value, j - (pwrs - 1), pwrs)
　　　　　　　　Else
　　　　　　　　T2C = "double power N/A": Exit Function
　　　　　　　　End If
　　　　　　End If
　　　　　　If ssflg Then
　　　　　　　　'累乗処理
　　　　　　　　buf = Mid$(buf, 1, Len(buf) - pwrs) & "^" & Right(buf, pwrs)
　　　　　　　　strArg = buf & strArg
　　　　　　　　buf = ""
　　　　　　　　ssflg = False
　　　　　　End If
　　　　Next j
　　End If '半角へ変換
strArg = StrConv(strArg, vbNarrow)

For k = LBound(TOp) To UBound(TOp)
　　If TOp(k) = "√" Then
　　　　If InStr(strArg, "√") > 0 Then
　　　　　　'√を変換するための関数
　　　　　　strArg = RootExchange(strArg)
　　　　End If
　　Else
　　　　strArg = Replace(strArg, TOp(k), Op(k))
　　End If
Next k

T2C = Application.Evaluate(strArg)
End Function

お礼

回答ありがとうございます。

指数は前にあっても後ろにあっても正常になりました。

ただ、指数が2回出る場合、エラー表示せず、誤計算するようです。

これ以上はご迷惑がかかるので、今はこれで使用してみます。

また時間があればお願いいたします。

回答No.2

Wendy02

こんにちは。
作り直してみました。

そこで、指数に関しては、基本的には、1桁を用いる場合のみになります。
[^2は、書式で設定されているものとします]

3^2×2　　　　=T2C(A1)

3^10×2　　　=T2C(A1,2)　　　'この場合は、引数を入れると解は出ます。

ただし、指数が、二つになると、
2^2×2+2^3　 =T2C(A1)　

で行うと、エラーを出すようにしてあります。最初の「上付き文字」側が、今の方法からでは、１度目の「上付き文字」を認識する方法が見つかりません。

今までのものに、入れ替えてください。
'-----------------------------------------------------------

Public Function T2C(セル As Variant, Optional pwrs As Integer = 1) As Variant
'goo_no.2848879 20.03.07_v.0.3
Dim strArg As String
Dim ssflg As Boolean
Dim rng As Range
Dim TOp As Variant
Dim Op As Variant
Dim i As Integer
Dim j As Integer
Dim buf As String
Dim k As Integer
'pwrs = 1 '累乗の桁

'√は、必ず、最後にしてください。
'本来は、＋,－は、文字列を半角にしてしまうので不要です。
Const TXTOPERAND As String = "[,],{,},＋,－,×,÷,π,√"
Const OPERAND As String = "(,),(,),+,-,*,/,PI(),SQRT"

TOp = Split(TXTOPERAND, ",")
Op = Split(OPERAND, ",")

'Altered Two Byte Argument to One Byte Variable
Set rng = セル

If StrComp(TypeName(rng), "RANGE", vbTextCompare) <> 0 Then Exit Function
If VarType(rng) = vbDouble Then T2C = rng.Value: Exit Function
'SuperScript Checking
　If Not rng.Characters(1).Font.Superscript = Null Then
　　　　For i = 1 To Len(rng.Value)
　　　　　　If rng.Characters(i).Font.Superscript = True And ssflg = False Then
　　　　　　　　strArg = strArg & "^" & Mid$(rng.Value, i, 1)
　　　　　　　　ssflg = True
　　　　　　Else
　　　　　　　　strArg = strArg & Mid$(rng.Value, i, 1)
　　　　　　End If
　　　　Next i
　　Else
　　　　For j = 1 To Len(rng.Value)
　　　　　　If rng.Characters(j).Font.Superscript = False And ssflg = False Then
　　　　　　　　strArg = strArg & Mid$(rng.Value, j, 1)
　　　　　　　　If buf <> "" Then ssflg = True
　　　　　　ElseIf IsNull(rng.Characters(j).Font.Superscript) And ssflg = False Then
　　　　　　　　buf = buf & Mid$(rng.Value, j, 1)
　　　　　　ElseIf rng.Characters(j).Font.Superscript Then
　　　　　　　　T2C = "double power N/A": Exit Function
　　　　　　End If
　　　　　　If ssflg Then
　　　　　　　　'累乗処理
　　　　　　　　buf = Mid$(buf, 1, Len(buf) - pwrs) & "^" & Right(buf, pwrs)
　　　　　　　　strArg = buf & strArg
　　　　　　　　buf = ""
　　　　　　　　ssflg = False
　　　　　　End If
　　　　Next j
　　End If '半角へ変換
strArg = StrConv(strArg, vbNarrow)

For k = LBound(TOp) To UBound(TOp)
　　If TOp(k) = "√" Then
　　　　If InStr(strArg, "√") > 0 Then
　　　　　　'√を変換するための関数
　　　　　　strArg = RootExchange(strArg)
　　　　End If
　　Else
　　　　strArg = Replace(strArg, TOp(k), Op(k))
　　End If
Next k

T2C = Application.Evaluate(strArg)
End Function

Private Function RootExchange(strArg As String) As String
'ルートを変換するための関数
　　Dim flg As Boolean
　　Dim buf As String
　　Dim i As Integer
　　If Len(strArg) - Len(Replace(strArg, "√", "")) > 1 Then
　　　　For i = 1 To Len(strArg)
　　　　　　If Mid(strArg, i, 1) = "√" And flg = False Then
　　　　　　　　buf = buf & "SQRT("
　　　　　　　　flg = True
　　　　　　ElseIf Mid(strArg, i, 1) Like "[.0-9]" Then
　　　　　　　　buf = buf & Mid(strArg, i, 1)
　　　　　　ElseIf Mid(strArg, i, 1) = "√" Then
　　　　　　　　buf = buf & ")SQRT"
　　　　　　　　flg = True
　　　　　　Else
　　　　　　　　If flg Then
　　　　　　　　　　　　buf = buf & ")" & Mid(strArg, i, 1)
　　　　　　　　　　　　flg = False
　　　　　　　　Else
　　　　　　　　　　　　buf = buf & Mid(strArg, i, 1)

　　　　　　　　End If

　　　　　　End If
　　　　Next i
　　 Else
　　　 buf = Replace(strArg, "√", "SQRT(")
　　　 flg = True
　　End If
　　If flg = True Then
　　　　RootExchange = buf & ")"
　　Else
　　　　RootExchange = buf
　　End If
End Function

お礼

Wendy02さん　ありがとうございます。
早速使わせてもらいました。

今度は逆の現象が起こります。
3^2×2 →　ＯＫ
2×3^2 →　double power N/A　です。

自力ではも不可能となってます。(^^ゞ
またよろしくお願いします。

回答No.1

Wendy02

こんにちは。Wendy02です。

現象は確認したのですが、なぜ、そんなことが起こるのか原因が良く分からないでいます。ユーザー定義関数の動きを、VBE のローカルウィンドウで確認してみてみましたら、VBA自身が、3^2×2（実際は^2は、[^]がなく書式だけ） の　2の部分の「上付き文字」が、認識できずに「抜け=null」が起きています。

もう一度、最初から、調べないといけないようです。すみませんが、単純にコードのミスとも言えないので、しばらくお時間いただけないでしょうか？