EXCEL で符丁計算式を設定したいのですが・・

Question

符丁
Aが1、Bが3・・・Jが「0｝　更にLと言う前の数字
例えば　数字10の場合＝AJ
　　　　数字２５の場合＝AE
　　　　数字225の場合＝BLE
　　　　数字1200の場合＝ABJL
　　　　数字10000の場合＝AJLJL
Lha前の数字
これをオートSUMで計算できる
VBAと思うのですが、何処にどの様なプログラムを入れれば良いのか
お教え下さい
EXCELは2013(15.0.4981.1000）です

WindFaller · Accepted Answer

こんばんは。

私が最後にパソコンを教わった先生は、当時72歳でした。それから、4～5年経ちます。
私の教わった先生は、60歳過ぎてからExcelの勉強をしたと言っております。ここの一部の回答者もかなり年齢の上の人がいるようです。

そして、60歳過ぎてからプログラミングの勉強をして。新企業を立ち上げたという人もいますし、また、60歳過ぎてから、VBAを教えることに意欲を持って、実際の場で教えている人もいます。自分の中で固まってしまわなければ、いくつでも、覚えられるものです。
ただ、どこでも、女性陣のほうが強いようです。

>VBAの深さで単に計算式でなく実務応用を考えさせられました。

このExcelには、想像できないような使い方もあります。

私が、例えば、OkWave に移行しないで、教えて！gooにいるのは、ここの掲示板の構造上の問題で、ブラウザを使わずに、Excelで、閲覧しているからなのです。

Excelで、それぞれのカテゴリのリストを取って、必要な内容のものは、テキストにして保存して、そのテキストのID番号やキーワード検索して、そのテキストを開くなんていうことをしています。

世の中、どんどん進んでいるけれども、ついていくこと、覚えることには精いっぱいです。

なお、今回のものを一部修正して、アップロードしておきました

mx いくつなのかは、正しいのかどうなのかは、まだ、よく検査されていません。
　　　ActiveCell.FormulaLocal = "=SumChrs(" & Range(Cells(rw, first), Cells(rw, mx )).Address(0, 0) & ")"
　　　Application.SendKeys "{F2}"
　　 ElseIf vstg > 0 Then
　　 ActiveCell.FormulaLocal = "=SumChrs(" & Range(Cells(first, col), Cells(mx, col)).Address(0, 0) & ")"

アップロード先は、
http://bit.ly/2nrPlTR
パスワードは、
URL のQAから後の8桁の数字です。(Open は、本日から、2017/12/18 までです。）
ダウンロード後、右クリック、プロパティーブロック解除をしてください。
よろしかったらお試しください。何かを学ぶきっかけとなったら幸いです。

WindFaller · Answer

こんにちは。

何か不思議な計算ですね。実に面白いです。
もし、ご質問と意味が違っていましたら、見過ごしてください。
まだ、中途の段階です。

'標準モジュール
Function Convert_AtoN(ByVal Text As String)
'文字から数字
　Dim i As Long
　Dim buf As String
　Dim a As String, n As String
　Dim n1 As String
　If Text Like "[A-L]*" Then
　　For i = 1 To Len(Text)
　　　a = Mid(Text, i, 1)
　　　n = Switch(a = "A", "1", a = "B", "2", a = "C", "3", a = "D", "4", a = "E", "5", _
　　　　　a = "F", "6", a = "G", "7", a = "H", "8", a = "I", "9", a = "J", 0, a = "L", n1)
　　　buf = buf & n
　　　n1 = n
　　　n = ""
　　Next
　End If
　Convert_AtoN = buf
End Function
Function Convert_NtoA(ByVal Text As String)
'数字から文字へ
　Dim i As Long
　Dim buf As String
　Dim a As String, n As String
　Dim a1 As String
　If IsNumeric(Text) Then
　　For i = 1 To Len(Text)
　　　n = Mid(Text, i, 1)
　　　a = Switch(n = "1", "A", n = "2", "B", n = "3", "C", n = "4", "D", n = "5", "E", _
　　　　　n = "6", "F", n = "7", "G", n = "8", "H", n = "9", "H", n = "0", "J")
　　　If a1 = a Then a = "L"
　　　buf = buf & a
　　　a1 = a: a = ""
　　Next
　End If
　Convert_NtoA = buf
End Function
Function SumChrs(ParamArray chrs())
　Dim n As Variant
　Dim c As Variant
　Dim nums As Double
　Dim mTotal As Double
　For Each n In chrs
　　If TypeName(n) = "Range" Then
　　　For Each c In n
　　　　c = c.Value
　　　　If VarType(c) = vbString Then
　　　　　If c Like "[A-L]*" Then
　　　　　　nums = Convert_AtoN(c)
　　　　　ElseIf IsNumeric(n) Then
　　　　　　nums = Val(n)
　　　　　End If
　　　　End If
　　　　mTotal = mTotal + nums
　　　Next
　　End If
　Next
　SumChrs = mTotal
End Function
'//

さて使い方ですが、

最初に、添付画像をみてください。
A列はふつうの数字
B列のB1:B5 は、
B1: =Convert_NtoA(A1)
として、ドラッグコピーで、B5 までしています。
B6は、

=Convert_NtoA((SumChrs(B1:B5)))
つまり、数値で出たものを、もう一度、Convert_NtoAで、文字に変換しています。
SumChrs(B1:B5)　で、数値の計算は出ています。

C列は、正しいか調べるために、
C1: =Convert_AtoN(B1)
で、C6 までドラッグコピーしています。

当面の実用にはたかられるのですが、では、何が中途かというと、SumChrs(B1:B5)は、SUM関数と同じように、文字を除外したり、単独の引数を入れても、計算するように出来ていますが、これは、まだ、セルの範囲だけなのです。SUM関数と同等の処理ができるには、ちょっと手間が掛かりそうな気がしています。
まだ、LIKE演算子を使った所などは不満を感じています。
>これをオートSUMで計算できる
これについても可能ですが、組み込むことは、一般の人には未知の世界になってしまうと思います。リボンカスタマイズというワザが必要なのです。

fujillin · Answer

こんにちは

ユーザ定義関数にしてみましたが、不明な点は勝手に限定しています。
・とりあえず大文字の指定文字のみに対応
　（A～JおよびL以外の文字が混ざっている場合は、エラー値になります）
　（無視という案もありそうですが、まずは、エラーとしました）
・Lが連続する場合は、それ以前の意味を持つ文字が連続するものと解釈します
・最初の文字がLだったり、Lが連続する場合は（前の文字が無いので）無視します
・空白文字列や"LLL"のように有効な文字が存在しない場合は0とみなします。

利用法は
　=futyou(A1)　あるいは　=futyou(A1:A15)
のような記法となります。
引数にセル範囲を指定した場合は、その範囲のセルを符丁と見做した合計値が返されます。
（通常のSUM関数とは異なり、エラーとなる値が混ざっていると結果はエラーになります）

=futyou(A1)*20 とか　=futyou(A1) - futyou(A2)
なども、もちろん可能です。

Function futyou(ByRef r As Range) As Variant

Dim c As Range
Dim v As String, str As String
Dim so As String, st As String
Dim i As Integer, sum

futyou = 0
For Each c In r
　v = c.Value
　str = ""
　so = ""
　For i = 1 To Len(v)
　　st = Mid(v, i, 1)
　　If st <> "L" Then so = st
　　str = str & so
　Next i

sum = 0
　For i = 1 To Len(str)
　　v = Mid(str, i, 1)
　　If "A" <= v And v <= "J" Then
　　　sum = sum * 10 + ((Asc(v) - 64) Mod 10)
　　Else
　　　futyou = CVErr(xlErrValue)
　　　Exit Function
　　End If
　Next i
futyou = futyou + sum
Next c

End Function

WindFaller · Answer

#1の回答者です。
>VBAの面白さを感じましたので、これから勉強しますのでご教示ください。
私でよければ、お教えします。

>Dim n1 As String　などの言葉を調べ　無事出来ました
VBAに嫌われないで、無事にたどり着けたことは、とても良かったです。

まだ、私としては直したい所がありますし、他にも不具合があるかもしれません。しばらく開けておいてください。

最終的には、アドインにしてあげると良いと思います。そうすれば、拡張子などの制約がなくなります。

それから、オートSUMのカスタマイズ・サンプルコードは、
https://oshiete.goo.ne.jp/qa/9325461.html　#6
にあります。リボン・カスタマイザーで作ります。VBマクロ言語ではなく、XMLで書きます。

WindFaller · Answer

遅くなりました。
今までとそんなに変わっていないと言われれば、そうかもしれませんが、いくつか苦心しました。カスタマイズしやすいように、文字をきれいに並べました。
合計のSUMChrs()　は、100%Excel関数のSUMとは同じではないのですが、似せました。A1:A10 という範囲でも、A1:A5,A7:A8 という引数でも、受けられるようにしました。

'//標準モジュール
Public Function Convert_AtoN(ByVal Text As String)
'文字から数字
　Dim i As Long
　Dim buf As String
　Dim a As String, n As String
　Dim n1 As String
　Text = StrConv(Text, vbNarrow + vbUpperCase)
　　For i = 1 To Len(Text)
　　　a = Mid(Text, i, 1)
　　　If Not a Like "[A-Z\.]" Then Convert_AtoN = CVErr(xlErrValue): Exit Function
　　　n = Switch(a = "A", "1", a = "B", "2", _
　　　 a = "C", "3", a = "D", "4", _
　　　 a = "E", "5", a = "F", "6", _
　　　 a = "G", "7", a = "H", "8", _
　　　 a = "I", "9", a = "J", 0, _
　　　 a = "L", n1, a = ".", ".")
　　　buf = buf & n
　　　n1 = n
　　　n = ""
　　Next
　Convert_AtoN = Val(buf)
End Function
Public Function Convert_NtoA(ByVal Text As String)
'数字から文字へ
　Dim i As Long
　Dim buf As String
　Dim a As String, n As String
　Dim a1 As String
　If IsNumeric(Text) Then
　　For i = 1 To Len(Text)
　　　n = Mid(Text, i, 1)
　　　a = Switch(n = "1", "A", n = "2", "B", _
　　　　 n = "3", "C", n = "4", "D", _
　　　　 n = "5", "E", n = "6", "F", _
　　　　 n = "7", "G", n = "8", "H", _
　　　　 n = "9", "H", n = "0", "J", _
　　　　 n = ".", ".")
　　　If a1 = a Then a = "L"
　　　buf = buf & a
　　　a1 = a: a = ""
　　Next
　End If
　Convert_NtoA = buf
End Function
Public Function SumChrs(ParamArray chrs())
'合計(少し甘くできています)
　Dim n As Variant
　Dim c As Variant
　Dim nums As Double
　Dim mTotal As Double
　For Each n In chrs
　　If TypeName(n) = "Range" Or IsArray(n) Then
　　　For Each c In n
　　　　If TypeName(c) = "Range" Then
　　　　　c = c.Value
　　　　End If
　　　　If VarType(c) = vbString Then
　　　　　If c Like "[A-L]*" Then　'*
　　　　　　nums = Convert_AtoN(c)
　　　　　ElseIf IsNumeric(n) Then
　　　　　　nums = Val(n)
　　　　　End If
　　　　End If
　　　　mTotal = mTotal + nums
　　　Next
　　Else
　　　mTotal = mTotal + n
　　End If
　Next
　SumChrs = mTotal
End Function

'　---続き--

WindFaller · Answer

Excelのオートサム(Σ)ボタンに取りけるコードです。これは、リボンエディタを使ってファイルに封入します。専用エディタがないとこれは難しいのですが、このように作るという参考まででも構いません。エディタは、Leaf Crations "Office Ribbon Editor" Ver4.4.2 で、それ以上のバージョンはおそらくは偽物だと思います。また、Multilanguage とそうでないものがありますので、そうでないものは、英語だけにしたほうがよいです。 'Excel 2007でも可動します。 '------------------------ '----------------------- '**Excelの標準モジュール** 'CallBack Ribbbon, On Action 'リボンをカスタマイズしないと、以下は動きません。 '組み込んでも、オートサムボタンは通常どおり使えますが、Ctrl キーを押しながら、オートサム(Σ)ボタンを押すと、符丁の計算をしてくれます。こちらは、文字列の判定が厳しくなっています。 'Re.IgnoreCase = True: Re.Pattern = "[A-Z]+" '"[A-Z]+" は、繋がってれば　－(ハイフン)でつなげてよいのですが、そうでなければ、 '[ACNTZ]+ としてください。なお、空白値が入らないように気をつけてください。 ' Option Explicit Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long Const VK_CONTROL = &H11 Sub CustomAutoSum(control As IRibbonControl, ByRef cancelDefault) 　Dim Re As Object 　Dim c As Variant 　Dim n As Variant 　Dim buf As Double '　Dim buf1 As Variant 　Dim col As Long, rw As Long, mx As Long 　Dim rTxt As String 　Dim vstg As Long 　Dim hstg As Long 　Dim i As Long, first As Long 　　Application.StatusBar = False 　If TypeName(Selection) <> "Range" Or GetAsyncKeyState(VK_CONTROL) = False Then 　　cancelDefault = False 　Exit Sub 　End If 　Set Re = CreateObject("VBScript.RegExp") 　Re.IgnoreCase = True: Re.Pattern = "[A-Z]+" 　 col = ActiveCell.Column 　 rw = ActiveCell.Row 　If col > 1 Then 　　If Re.test(Cells(rw, col - 1).Value) Then 　　　 hstg = col - 1 　　End If 　End If 　If rw > 1 Then 　　If Re.test(Cells(rw - 1, col).Value) Then 　　　 vstg = rw - 1 　　End If 　End If 　If hstg > 0 And vstg = 0 Then 　　mx = hstg 　ElseIf vstg > 0 And hstg = 0 Then 　　mx = vstg 　ElseIf vstg > 0 And hstg > 0 Then 　　mx = vstg 　　hstg = 0 　Else 　　Exit Sub 　End If 　　For i = mx - 1 To 1 Step -1 　　If hstg > 0 Then 　　rTxt = Cells(rw, mx - i).Value 　　If Re.test(rTxt) = False Then 　　　first = mx - i + 1 　　 End If 　　ElseIf vstg > 0 Then 　　　rTxt = Cells(mx - i, col).Value 　　　If Re.test(rTxt) = False Then 　　　　first = mx - i + 1 　　　End If 　　End If 　Next i 　If first = 0 Then first = 1 　　　 If hstg > 0 Then 　　　ActiveCell.FormulaLocal = "=SumChrs(" & Range(Cells(rw, first), Cells(rw, mx - i)).Address(0, 0) & ")" 　　　Application.SendKeys "{F2}" 　　 ElseIf vstg > 0 Then 　　 ActiveCell.FormulaLocal = "=SumChrs(" & Range(Cells(first, col), Cells(mx - 1, col)).Address(0, 0) & ")" 　　　Application.SendKeys "{F2}" 　　 End If End Sub '// こういうものは、遊びだと言われれば、否定はしませんが、SUM関数そのものは、アメリカの大学の授業の最中に学生二人が作ったという伝説が残っています。その人たちに敬意を払って、こだわざるを得ません。そして、気持ちの問題なのでしょうけれども、私は、後、どのぐらい続けられるのだろうか、と思います。ここの掲示板を利用している人たちの年齢も、だんだん高くなっているようです。最近は、切磋琢磨というものには似つかわしくない状況が続きます。

EXCEL で符丁計算式を設定したいのですが・・

こんにちは。

こんにちは

#1の回答者です。

遅くなりました。

Excelのオートサム(Σ)ボタンに取りけるコードです。

こんばんは。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング