Word VBA 漢数字をアラビア数字に変えてフィールドコードで挿入するマクロ

• 正規表現ではなくDictironaryメインです。
• 壱二三四五でも一萬二千三百四拾五でも置換します。大字と通常の表記が混在しても置換します。
• 正の数限定です。
• その代わり、小数でも置換します。整数部がゼロの場合でないと正確ではありません。例えば百八分は100.08になります。分数表記のときが注意が必要です。
• Excelより大きな数を平気で扱います。百京など普通は整数で表記できないのですが、Wordのフィールドコードは可能です。ただし、15桁程度が有効数字のため、それより離れると、失敗します。
• たとえば五京二千五は50,000,000,000,002,005ではなく、 50,000,000,000,002,000になり、1の位の五が消えます。1の位は1京の位と17桁離れているためです。しかし五京四千億は上位14桁以内に収まるため、置換されます。
• 巨大な数を変換するには、4桁ごとに切ってフィールドコードにすると可能になります。無量大数のような数でも理論的に置換可能です。
• 数字をかっこで囲むと、マイナスになります。(4)はマイナス4です。ただし(4*5)のような式はマイナスになりません。
• 漢数字でマイナス表記（三角を追加）のようなものは極稀にしか見たことがないので、符号と別に置換すればいいように思います。
• かっこに深く入っている数字は上記のように勝手にマイナスになりうるため、正規表現で一度取り出します。
• （）の数の調整のためOffice田中大先生の[文字列内の文字をカウントする](http://officetanaka.net/excel/vba/tips/tips152.htm)を使っています。
• 整数は3桁より小さいと半角スペースが一つ入ります。小数は半角スペースが1個か2個入るときがあります。
• これは#が数字がないときは半角になるためです。
• 人に渡すときはフィールドコードを解除したものを渡すようにしましょう。

仕組み

1. まず辞書をロードし、InputBoxで漢数字を入力してもらいます。
2. 入力された漢数字が単純に漢数字を並べたものであれば、そのまま置換します。
3. それ以外は、上から順に京、兆、億、万の順に切り分けます。
4. 個々に変換します。
5. 全部合成して置換してかっこ等を調整します
6. 予め用意した書式のフィールドコードを挿入します。
7. 半角1字右に移動して、フィールドコードが選択状態であることを解除します。

コード

Sub InsFldCnCharNumberToArabicNumWithComma()
' for word
' Ver001-2020-10-20
' 正の数のみ
' 負の数はカッコを追加するとできるが、最後の調整ができない
' 漢数字を入れると、それに見合う数字のフィールドコードが入る
' 割  分、厘の時は小数点表示される
' 14桁以上離れると正しく表示されない可能性があります例：五京二千五、五京二千で五はなくなります50,000,000,000,002,000
' debug.PrintはCdecを入れないと、簡単にオーバーフローします。3万ちょっとが限界です。Clngでもいいです。

Dim wDoc As Document: Set wDoc = ThisDocument
Dim wRng As Word.Range
Dim iDic As Long, odKey, odItm, oDic: Set oDic = CreateObject("Scripting.Dictionary")
Dim keyAr, Itmar
Dim buf As String, buf1 As String, nBuf As String, inBuf As Long, mBuf As String, imBuf As Long, icbuf As Long, cbuf As String, iobuf As Long, obuf As String, ikBuf As Long, kbuf As String
Dim Lpare As Long, rpare As Long
Dim x
Dim MC, M, iM, SMs, Reg: Set Reg = CreateObject("VBSCript.Regexp")
Dim FormulaType As Long
Dim idig As Long
x = InputBox("漢数字で入力してください", "漢数字アラビア数字変換", "百兆十億五千二百十万六千弐佰壱")
oDic.Add "厘", "*0.001+"
oDic.Add "分", ")*0.01+"
oDic.Add "割", ")*0.1+"
oDic.Add "零", 0
oDic.Add "〇", 0
oDic.Add "一", 1
oDic.Add "壱", 1
oDic.Add "壹", 1
oDic.Add "二", 2
oDic.Add "弐", 2
oDic.Add "三", 3
oDic.Add "参", 3
oDic.Add "四", 4
oDic.Add "肆", 4
oDic.Add "五", 5
oDic.Add "伍", 5
oDic.Add "六", 6
oDic.Add "陸", 6
oDic.Add "七", 7
oDic.Add "漆", 7
oDic.Add "八", 8
oDic.Add "捌", 8
oDic.Add "九", 9
oDic.Add "玖", 9
oDic.Add "十", "*10+"
oDic.Add "拾", "*10+"
oDic.Add "廿", "+20+"
oDic.Add "卅", "+30+"
oDic.Add "丗", "+30+"
oDic.Add "百", "*100+"
oDic.Add "佰", "*100+"
oDic.Add "千", "*1000+"
oDic.Add "仟", "*1000+"
oDic.Add "万", "*10000+"
oDic.Add "萬", "*10000+"
oDic.Add "億", "*100000000+"
oDic.Add "兆", "*1000000000000+"
oDic.Add "京", "*10000000000000000+"
'buf = Selection.Text
keyAr = oDic.Keys
Itmar = oDic.items
buf = x
'京単位
If InStr(1, buf, "京", vbBinaryCompare) > 0 Then
ikBuf = InStr(1, buf, "京", vbBinaryCompare)
kbuf = Mid(buf, 1, ikBuf)
ikBuf = ikBuf + 1
buf = Replace(buf, kbuf, "", 1, 1)
Else
kbuf = ""
ikBuf = 1
End If
'兆単位
If InStr(1, buf, "兆", vbBinaryCompare) > 0 Then
icbuf = InStr(1, buf, "兆", vbBinaryCompare)
cbuf = Mid(buf, 1, icbuf)
icbuf = icbuf + 1
buf = Replace(buf, cbuf, "", 1, 1)
Else
cbuf = ""
icbuf = 1
End If

'億単位
If InStr(1, buf, "億", vbBinaryCompare) > 0 Then
iobuf = InStr(1, buf, "億", vbBinaryCompare)
obuf = Mid(buf, 1, iobuf)
buf = Replace(buf, obuf, "", 1, 1)
Else
obuf = ""
End If

'万単位
If InStr(1, buf, "万", vbBinaryCompare) > 0 Then
imBuf = InStr(1, buf, "万", vbBinaryCompare)
mBuf = Mid(buf, 1, imBuf)
buf = Replace(buf, mBuf, "", 1, 1)
Else
mBuf = ""
End If
'千まで
If InStr(1, buf, "万", vbBinaryCompare) > 0 Then
inBuf = InStr(1, buf, "万", vbBinaryCompare)
nBuf = Mid(buf, 1, inBuf)
buf = Replace(buf, nBuf, "", 1, 1)
Else
nBuf = ""
End If

'京単位を変換
If kbuf <> "" Then
kbuf = Replace(kbuf, "京", "")
For iDic = oDic.Count - 1 To 0 Step -1
kbuf = Replace(kbuf, keyAr(iDic), Itmar(iDic), 1, -1, vbBinaryCompare)
Next
kbuf = "((" & kbuf
kbuf = Replace(kbuf, "(*1000+", "(1*1000+", 1, -1)
kbuf = Replace(kbuf, "+(*1000)", "+1000", 1, -1)
kbuf = Replace(kbuf, "(*100+", "(1*100+", 1, -1)
kbuf = Replace(kbuf, "+(*100)", "+100", 1, -1)
kbuf = Replace(kbuf, "+(*10)", "+10", 1, -1)
kbuf = Replace(kbuf, "(*10+", "(1*10+", 1, -1)
kbuf = Replace(kbuf, "+*", "+1*", 1, -1)
kbuf = kbuf & ")"
kbuf = Replace(kbuf, "+)", ")", 1, -1)
kbuf = Replace(Replace(kbuf & ")*10000000000000000", "((", "(", 1, 1), "))", ")", 1, 1)
kbuf = excludeNumberParenth(kbuf)
   'かっこの調整
Lpare = StrCount(kbuf, "(")
rpare = StrCount(kbuf, ")")
If Lpare > rpare Then
kbuf = kbuf & String(Abs(Lpare - rpare), ")")
ElseIf Lpare < rpare Then
kbuf = String(rpare - Lpare, "(") & kbuf
End If
End If
'兆単位を変換
If cbuf <> "" Then
cbuf = Replace(cbuf, "兆", "")
For iDic = oDic.Count - 1 To 0 Step -1
cbuf = Replace(cbuf, keyAr(iDic), Itmar(iDic), 1, -1, vbBinaryCompare)
Next
cbuf = "((" & cbuf
cbuf = Replace(cbuf, "(*1000+", "(1*1000+", 1, -1)
cbuf = Replace(cbuf, "+(*1000)", "+1000", 1, -1)
cbuf = Replace(cbuf, "(*100+", "(1*100+", 1, -1)
cbuf = Replace(cbuf, "+(*100)", "+100", 1, -1)
cbuf = Replace(cbuf, "+(*10)", "+10", 1, -1)
cbuf = Replace(cbuf, "(*10+", "(1*10+", 1, -1)
cbuf = Replace(cbuf, "+*", "+1*", 1, -1)
cbuf = cbuf & ")"
cbuf = Replace(cbuf, "+)", ")", 1, -1)
cbuf = Replace(Replace(cbuf & ")*1000000000000", "((", "(", 1, 1), "))", ")", 1, 1)
cbuf = excludeNumberParenth(cbuf)
   'かっこの調整
Lpare = StrCount(cbuf, "(")
rpare = StrCount(cbuf, ")")
If Lpare > rpare Then
cbuf = cbuf & String(Abs(Lpare - rpare), ")")
ElseIf Lpare < rpare Then
cbuf = String(rpare - Lpare, "(") & cbuf
End If
End If
'億単位を変換
If obuf <> "" Then
obuf = Replace(obuf, "億", "")
For iDic = oDic.Count - 1 To 0 Step -1
obuf = Replace(obuf, keyAr(iDic), Itmar(iDic), 1, -1, vbBinaryCompare)
Next
obuf = "((" & obuf
obuf = Replace(obuf, "(*1000+", "(1*1000+", 1, -1)
obuf = Replace(obuf, "+(*1000)", "+1000", 1, -1)
obuf = Replace(obuf, "(*100+", "(1*100+", 1, -1)
obuf = Replace(obuf, "+(*100)", "+100", 1, -1)
obuf = Replace(obuf, "+(*10)", "+10", 1, -1)
obuf = Replace(obuf, "(*10+", "(1*10+", 1, -1)
obuf = Replace(obuf, "+*", "+1*", 1, -1)
obuf = obuf & ")"
obuf = Replace(obuf, "+)", ")", 1, -1)
obuf = Replace(Replace(obuf & ")*100000000", "((", "(", 1, 1), "))", ")", 1, 1)
obuf = excludeNumberParenth(obuf)
   'かっこの調整
Lpare = StrCount(obuf, "(")
rpare = StrCount(obuf, ")")
If Lpare > rpare Then
obuf = obuf & String(Abs(Lpare - rpare), ")")
ElseIf Lpare < rpare Then
obuf = String(rpare - Lpare, "(") & obuf
End If
End If

'万単位を変換
If mBuf <> "" Then
mBuf = Replace(mBuf, "万", "")
mBuf = Replace(mBuf, "萬", "")
For iDic = oDic.Count - 1 To 0 Step -1
mBuf = Replace(mBuf, keyAr(iDic), Itmar(iDic), 1, -1, vbBinaryCompare)
Next
mBuf = "((" & mBuf
mBuf = Replace(mBuf, "(*1000+", "(1*1000+", 1, -1)
mBuf = Replace(mBuf, "+(*1000)", "+1000", 1, -1)
mBuf = Replace(mBuf, "(*100+", "(1*100+", 1, -1)
mBuf = Replace(mBuf, "+(*100)", "+100", 1, -1)
mBuf = Replace(mBuf, "+(*10)", "+10", 1, -1)
mBuf = Replace(mBuf, "(*10+", "(1*10+", 1, -1)
mBuf = Replace(mBuf, "+*", "+1*", 1, -1)
mBuf = mBuf & ")"
mBuf = Replace(mBuf, "+)", ")", 1, -1)
mBuf = Replace(Replace(mBuf & ")*10000", "((", "(", 1, 1), "))", ")", 1, 1)
mBuf = excludeNumberParenth(mBuf)
  'かっこの調整
Lpare = StrCount(mBuf, "(")
rpare = StrCount(mBuf, ")")
If Lpare > rpare Then
mBuf = mBuf & String(Abs(Lpare - rpare), ")")
ElseIf Lpare < rpare Then
mBuf = String(rpare - Lpare, "(") & mBuf
End If
End If

'小数点以下の表記を換算するブロック
If buf Like "*厘*" Then
FormulaType = 2
ElseIf (buf Like "*分*") And (Not buf Like "*厘*") Then
FormulaType = 1
ElseIf (buf Like "*割*") And (Not buf Like "*厘*") And (Not buf Like "*分*") Then
FormulaType = 1
ElseIf (buf Like "割") And ((buf Like "*厘*") Or (Not buf Like "*分*")) Then
FormulaType = 2
Else
FormulaType = 0
End If
For iDic = 0 To oDic.Count - 1
buf = Replace(buf, keyAr(iDic), Itmar(iDic), 1, -1, vbBinaryCompare)
Next
If Left(buf, 1) = "*" Then buf = "(1" & buf
buf = "(" & buf
buf = Replace(buf, "*10000+", "))*10000)+(", 1, 1, vbTextCompare)
buf = Replace(buf, "(*1000+", "(1*1000+", 1, -1)
buf = Replace(buf, "+(*1000)", "+1000", 1, -1)
buf = Replace(buf, "(*100+", "(1*100+", 1, -1)
buf = Replace(buf, "+(*100)", "+100", 1, -1)
buf = Replace(buf, "+(*10)", "+10", 1, -1)
buf = Replace(buf, "(*10+", "(1*10+", 1, -1)
buf = Replace(buf, "(*1+", "(1+", 1, -1)
buf = Replace(buf, "+(*1)", "+1", 1, -1)
'小数点以下
buf = Replace(buf, ")*0.01+", "*0.01+", 1, 1)
buf = Replace(buf, ")*0.001+", "*0.001+", 1, 1)
buf = Replace(buf, "+(*1)", "+1", 1, -1)
buf = Replace(buf, "+*", "+1*", 1, -1)
buf = Replace(buf, "++", "+", 1, -1, vbBinaryCompare)

buf = buf & ")"
buf = Replace(buf, "+)", "))", 1, -1, vbBinaryCompare)
buf = "(" & buf
  'かっこの調整
Lpare = StrCount(buf, "(")
rpare = StrCount(buf, ")")
If Lpare > rpare Then
buf = buf & String(Abs(Lpare - rpare), ")") '修正
ElseIf Lpare < rpare Then
buf = String(rpare - Lpare, "(") & buf
End If
'通常の単位
If buf <> "" Then
For iDic = 0 To oDic.Count - 1
buf = Replace(buf, keyAr(iDic), Itmar(iDic), 1, -1, vbBinaryCompare)
Next
buf = "((" & buf
buf = Replace(buf, "(*1000+", "(1*1000+", 1, -1)
buf = Replace(buf, "+(*1000)", "+1000", 1, -1)
buf = Replace(buf, "(*100+", "(1*100+", 1, -1)
buf = Replace(buf, "+(*100)", "+100", 1, -1)
buf = Replace(buf, "+(*10)", "+10", 1, -1)
buf = Replace(buf, "(*10+", "(1*10+", 1, -1)
buf = Replace(buf, "+*", "+1*", 1, -1)
buf = buf & ")"
buf = Replace(buf, "+)", ")", 1, -1)
buf = Replace(Replace(buf & ")", "((", "(", 1, 1), "))", ")", 1, 1)
buf = excludeNumberParenth(buf)
  'かっこの調整
Lpare = StrCount(buf, "(")
rpare = StrCount(buf, ")")
If Lpare > rpare Then
buf = buf & String(Abs(Lpare - rpare), ")")
ElseIf Lpare < rpare Then
buf = String(rpare - Lpare, "(") & buf
End If
End If

'分解して換算した数字を再度構築する
'bufが空の時の調整
buf = "(" & kbuf & ")+(" & cbuf & ")+(" & obuf & ")+(" & mBuf & ")" & buf
buf = Replace(buf, "()+", "", 1, -1)
buf = Replace(buf, "+()", "", 1, -1)
buf = Replace(buf, ")(", ")+(", 1, -1)

Do
idig = Len(buf)
buf = Replace(buf, "()", "", 1, 1)
If idig = Len(buf) Then Exit Do
Loop
If Right(buf, 1) = "+" Then buf = Left(buf, Len(buf) - 1)
If Left(buf, 1) = "+" Then buf = Mid(buf, 2, Len(buf))

If idig > Len(buf) Then
With Reg
.Pattern = "(\({1,})([0-9]{1,})(\){1,})"
.Global = True
Set M = .Execute(buf)
If M.Count > 0 Then
buf = Replace(buf, M.Item(0).Value, M(0).SubMatches(1), 1, 1)
Else
buf = Replace(buf, "=((", "=(", 1, 1)
End If
End With
End If
Debug.Print Replace(Replace(Replace(Replace(Replace(buf, "*100+", "*cdec(100)+", 1, -1), "*1000+", "*Cdec(1000)+", 1, -1, vbBinaryCompare), "*10000000", "*cdec(10000000") & ")", 1, 1), "=", "?", 1, 1)

'付加する書式（表示形式）を選択
Select Case True
Case FormulaType = 0
Selection.InsertFormula Formula:="=" & buf, NumberFormat:="#,0"
Case FormulaType = 1
Selection.InsertFormula Formula:="=" & buf, NumberFormat:="#,0.0##"
Case FormulaType = 2
Selection.InsertFormula Formula:="=" & buf, NumberFormat:="#,0.####"
End Select

Selection.MoveRight Unit:=wdCharacter, Count:=1 '日本語で左から右に横書きをしている前提なので、これで移動することでフィールドコードの中に書き込むことや消すことを防ぐ。フィールドコードへのセレクションが解除される。

End Sub
Function excludeNumberParenth(strFormula As String) As String
' 数字が(((#))のようになっているとマイナスになるため、数字だけ取り出す
Dim Reg: Set Reg = CreateObject("VBScript.RegExp")
Dim M

With Reg
.Pattern = "(\({1,})([0-9]{1,})(\){1,})"
.Global = True
Set M = .Execute(strFormula)
If M.Count > 0 Then
strFormula = Replace(strFormula, M.Item(0).Value, M(0).SubMatches(1), 1, 1)
excludeNumberParenth = strFormula
Else
excludeNumberParenth = strFormula
End If
End With
End Function
Function StrCount(Source As String, Target As String) As Long
'http://officetanaka.net/excel/vba/tips/tips152.htm
Dim n As Long, cnt As Long
Do
n = InStr(n + 1, Source, Target)
If n = 0 Then
Exit Do
Else
cnt = cnt + 1
End If
Loop
StrCount = cnt
End Function