漢数字を算用数字に変換したい（緊急）

締切済

質問者：sinopusu
質問日時：2005/07/22 14:12
回答数：4件

いまwordで漢数字を算用数字に変換したくて困っています。
三十五を３５にしたいのですが何かいい方法ありませんか?
アドバイスお願いします。

通報する

この質問への回答は締め切られました。

質問の本文を隠す

回答 (4件)

最新から表示
回答順に表示

No.4

回答者： Wendy02
回答日時：2005/07/22 19:23

こんばんは。

即席で、マクロを作ってみました。
ThisDocument か、標準モジュールに登録してご利用ください。
まだ、試験段階ですが、この両方の漢数字を、対象にして、ThisDocument 内の全ての漢数字を変換します。

例:

一二三四五六七八九〇
十二億三千四百五十六万七千八百九十

なお、現在は、コンマ切りはしていません。
リクエストによって、直します。

マクロ名は、Kansu2Suji_henkan

Option Explicit
Sub Kansu2Suji_henkan()
Dim t As Integer, myMsg As String
Dim moji As String
Selection.HomeKey Unit:=wdStory '文書の先頭に
On Error GoTo Errmsg:
With Selection.Find
　　.ClearFormatting
　　.Text = ""
　　.Replacement.Text = ""
　　.MatchFuzzy = False
While .Execute(FindText:="[一二三四五六七八九兆億万千百十〇]{1,}", _
　　Wrap:=wdFindContinue, MatchWildcards:=True) = True
　　moji = Selection.Range
　　Selection.Range = Kansu2SujiDec(moji)
　　t = t + 1
　　If t = 0 Then GoTo Msg
Wend
Msg:
　　 Selection.HomeKey Unit:=wdStory　'文書の先頭に
　　 If t > 0 Then
　　　　myMsg = t & "語、変換しました。"
　　 Else
　　　　myMsg = "変換するべき数字はありません"
　　 End If
　　 MsgBox myMsg, , Title:="漢数字からアラビア数字に"
End With
　　Exit Sub
Errmsg:
　 MsgBox "エラー!: " & Err.Description, vbExclamation
End Sub
Private Function Kansu2SujiDec(ByVal moji As String)
　Dim i As Integer, k As Integer, m As Integer, j As Integer
　Dim fig As Double, buf As Double, bufk(1 To 3)
　Dim sum As Double, f As Variant, s As String
　Const keta1 As String = "〇一二三四五六七八九"
　If moji Like "[" & keta1 & "]" & "[" & keta1 & "]*" Then
　　s = moji
　　For j = 0 To Len(keta1) + 1
　　　s = Replace(s, Mid(keta1, j + 1, 1), CStr(j))
　　Next j
　　Kansu2SujiDec = CDbl(s)
　　Else
　　For i = 1 To Len(moji)
　　　fig = myFindfig(Mid(moji, i, 2), k, m)
　　　If m > 0 Then
　　　　bufk(m) = buf * fig
　　　　buf = Empty
　　　　Else
　　　　buf = buf + fig
　　　End If
　　　i = i + k
　　　k = 0: m = 0
　　Next i
　　For Each f In bufk
　　　sum = sum + f
　　Next
　　Kansu2SujiDec = sum + buf
　End If
End Function
Private Function myFindfig(ByRef s As String, k As Integer, m As Integer)
　Dim lc1 As Integer, lc2 As Integer, lc3 As Integer
　Const keta1 As String = "一二三四五六七八九"
　Const keta2 As String = "十百千"
　Const keta3 As String = "万億兆"
　If s Like "[" & keta1 & "]" & "[" & keta2 & "kata3" & "]" Then
　　k = 1
　　lc1 = InStr(keta1, Left$(s, 1))
　　lc2 = InStr(keta2, Right$(s, 1))
　　lc3 = InStr(keta3, s)
　　If lc2 > 0 Then
　　　myFindfig = 10 ^ lc2 * lc1
　　ElseIf lc3 > 0 Then
　　　myFindfig = 10 ^ (4 + lc3 * 4)
　　End If
　　Else
　　lc1 = InStr(keta1, Left(s, 1))
　　lc2 = InStr(keta2, Left(s, 1))
　　lc3 = InStr(keta3, Left(s, 1))
　　If lc3 > 0 Then m = lc3
　　myFindfig = lc1 - (lc2 <> 0) * 10 ^ lc2 - (lc3 <> 0) * 10 ^ (lc3 * 4)
　End If
End Function