Sub myStrNum() Rem *----*----* *----*----* *----*----* *----*----* Rem 漢数字検索 洋数字置換 半自動処理 Rem 記録者:Hitrock Camellia Shinopy Rem 言語:Word VBA Rem 機能:漢数字を検索し、蛍光ペン書式を設定して、洋数字に置換する。 Rem 注記... Rem 「myStrNum」を起動して使用。 Rem 兆単位までの漢数字を検索。 Rem 蛍光ペン書式:25%灰色・水色を使用。 Rem 第1版:2004/11/30:作成。 Rem 第2版:2004/12/02:不具合修正。 Rem *----*----* *----*----* *----*----* *----*----* ' Rem カーソルが文章の途中あると、不都合が起こるので、 Rem 文章の先頭に移動する。 Selection.Sentences(1).Select Selection.Collapse wdCollapseStart ' Assistant.Visible = True ' With Assistant.NewBalloon .Animation = msoAnimationIdle .BalloonType = msoBalloonTypeButtons .Icon = msoIconAlertQuery .Button = msoButtonSetSearchClose .Heading = "漢数字検索" & vbCr & "洋数字置換" & vbCr & "半自動処理" .Text = "[検索]してから、" & vbCr & "選択して下さい。" .Labels(1).Text = "洋数字に置換" .Labels(2).Text = "次へ" .Labels(3).Text = "[元に戻す]" .Labels(4).Text = "" .Labels(5).Text = "蛍光ペン書式を解除" .Mode = msoModeModeless .Callback = "myStrNumExec" .Show End With End Sub ' myStrNum *----*----* *----*----* *----*----* *----*----* Sub myStrNumExec(blln As Balloon, bttn As Long, bllnID As Long) Dim myCmmdBar As CommandBar Dim myCtrl As CommandBarControl ' Set myCmmdBar = Application.CommandBars("Standard") ' 標準 Set myCtrl = myCmmdBar.FindControl(ID:=128) ' 元に戻す ' Select Case bttn Case 1 If Selection.Range.Text = "" Then Call myStrNumFind Else Call myStrNumReplace End If Case 3 Selection.Collapse wdCollapseStart Rem If myCtrl.TooltipText = "元に戻す VBA - Range.Text (Ctrl+Z)" Then Rem Application.GoBack Rem End If myCtrl.Execute Case 5 If MsgBox("蛍光ペン書式を解除しますか?", vbExclamation + vbYesNo + vbDefaultButton2, "蛍光ペン書式を解除") = vbNo Then Exit Sub End If Call myStrNumNoHighlight Case 2, -10 ' [検索]ボタン時 Call myStrNumFind Case -12 ' [閉じる]ボタン時 blln.Close Assistant.Animation = msoAnimationIdle Assistant.Visible = False Exit Sub End Select ' Assistant.Animation = msoAnimationIdle If Tasks.Exists(Name:="Microsoft Word") = True Then Tasks("Microsoft Word").Activate End If End Sub ' myStrNumExec *----*----* *----*----* *----*----* *----*----* Sub myStrNumFind() Rem *----*----* *----*----* *----*----* *----*----* Rem 漢数字を検索し、蛍光ペン書式25%灰色を設定する。 Rem *----*----* *----*----* *----*----* *----*----* With Selection.Find .ClearFormatting .Text = "[〇一二三四五六七八九十百千万億兆]{1,}" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With ' myStrNumFindSubEntry: Selection.Find.Execute If Not Selection.Find.Found Then Rem 検索した文字列がない場合。 GoTo myStrNumFindSubExit End If ' Rem 検索した文字列がある場合。 Select Case Selection.Range.HighlightColorIndex Case wdNoHighlight Selection.Range.HighlightColorIndex = wdGray25 Case wdTurquoise, wdGray25 Rem 既に蛍光ペン書式が設定されている場合。 Selection.Words(1).Select Selection.Collapse wdCollapseEnd GoTo myStrNumFindSubEntry End Select ' Exit Sub myStrNumFindSubExit: Selection.Collapse wdCollapseEnd MsgBox "検索終了!" End Sub ' myStrNumFind *----*----* *----*----* *----*----* *----*----* Sub myStrNumReplace() Rem *----*----* *----*----* *----*----* *----*----* Rem 選択範囲の文字列を洋数字に置換する。 Rem *----*----* *----*----* *----*----* *----*----* Dim myArray As Variant Dim myArrayDigitRev(1 To 20) As Variant Dim myFlagIsNumeric As Boolean Dim myFlagDigit As Integer Dim myFlagUnit As Integer Dim myTextCount As Long Dim myDigit As String Dim i As Integer Dim j As Integer ' Rem 選択範囲に蛍光ペン書式を設定する。 Selection.Range.HighlightColorIndex = wdTurquoise ' 水色 ' Rem 数値判断用の表を準備する。 myArray = Array("〇", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "百", "千", "万", "億", "兆", "京") ' Rem 位取りする漢数字の有無を調べる。 myTextCount = 0 myTextCount = myTextCount + InStr(Selection.Range.Text, "千") myTextCount = myTextCount + InStr(Selection.Range.Text, "百") myTextCount = myTextCount + InStr(Selection.Range.Text, "十") ' myStrNumReplaceSubEntry: Rem 位取りがない場合、漢数字から洋数字へ単純置換する。 If myTextCount = 0 Then myDigit = Selection.Range.Text myDigit = Replace(myDigit, "〇", "0") myDigit = Replace(myDigit, "一", "1") myDigit = Replace(myDigit, "二", "2") myDigit = Replace(myDigit, "三", "3") myDigit = Replace(myDigit, "四", "4") myDigit = Replace(myDigit, "五", "5") myDigit = Replace(myDigit, "六", "6") myDigit = Replace(myDigit, "七", "7") myDigit = Replace(myDigit, "八", "8") myDigit = Replace(myDigit, "九", "9") Selection.Range.Text = myDigit Selection.MoveRight Unit:=wdCharacter, Count:=Len(myDigit), Extend:=wdMove Exit Sub End If ' Rem 以下、位取りがある場合の漢数字から洋数字へ置換処理。 Rem 逆順表を準備する。 Selection.Collapse wdCollapseEnd For i = 1 To UBound(myArrayDigitRev) myArrayDigitRev(i) = "〇" Next i ' myFlagUnit = 1 ' 一の位 myFlagDigit = 0 With Selection.Range Do Rem 下の位から順に文字列を選択する。 myTextCount = Selection.MoveLeft(wdCharacter, 1, wdExtend) If myTextCount = 0 Then Exit Do End If ' Rem 選択した文字列が漢数字かどうか調べて、 Rem 逆順表に数値を転記する。 For i = 0 To UBound(myArray) If Left(Selection.Range.Text, 1) = myArray(i) Then myFlagIsNumeric = True Select Case myArray(i) Case "十" myFlagDigit = 1 Case "百" myFlagDigit = 2 Case "千" myFlagDigit = 3 Case "万" myFlagUnit = 5 Case "億" myFlagUnit = 9 Case "兆" myFlagUnit = 13 Case "京" myFlagUnit = 17 End Select Select Case myArray(i) Case "〇", "一", "二", "三", "四", "五", "六", "七", "八", "九" myArrayDigitRev(myFlagUnit + myFlagDigit) = myArray(i) Case "十", "百", "千" myArrayDigitRev(myFlagUnit + myFlagDigit) = "一" Case Else myArrayDigitRev(myFlagUnit) = "一" myFlagDigit = 0 End Select Exit For Else myFlagIsNumeric = False End If Next i ' Rem 上の位が漢数字でない場合は、右へ1文字分戻り、繰り返しを抜ける。 If myFlagIsNumeric = False Then Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend Exit Do End If Loop ' Rem 逆順表を元に洋数字に置換し、選択範囲の文字列を置換する。 myDigit = Join(myArrayDigitRev(), "") myDigit = Left(myDigit, myFlagUnit + myFlagDigit) myDigit = StrReverse(myDigit) myDigit = Replace(myDigit, "〇", "0") myDigit = Replace(myDigit, "一", "1") myDigit = Replace(myDigit, "二", "2") myDigit = Replace(myDigit, "三", "3") myDigit = Replace(myDigit, "四", "4") myDigit = Replace(myDigit, "五", "5") myDigit = Replace(myDigit, "六", "6") myDigit = Replace(myDigit, "七", "7") myDigit = Replace(myDigit, "八", "8") myDigit = Replace(myDigit, "九", "9") End With Selection.Range.Text = myDigit ' myStrNumReplaceSubExit: Rem 位取りを4桁ごとに文字列に挿入する。 If myFlagUnit < 5 Then Selection.MoveRight Unit:=wdCharacter, Count:=myFlagDigit + 1, Extend:=wdMove Else Selection.Collapse wdCollapseStart Select Case myFlagUnit Case 5 ' 万 j = 13 Case 9 ' 億 j = 14 Case 13 ' 兆 j = 15 Case 17 ' 京 j = 16 End Select Selection.MoveRight Unit:=wdCharacter, Count:=myFlagDigit + 1, Extend:=wdMove For i = 1 To ((myFlagUnit - 1) / 4) Selection.InsertBefore (myArray(j)) j = j - 1 Selection.MoveRight Unit:=wdCharacter, Count:=5, Extend:=wdMove Next i End If End Sub ' myStrNumReplace *----*----* *----*----* *----*----* *----*----* Sub myStrNumNoHighlight() Rem *----*----* *----*----* *----*----* *----*----* Rem 蛍光ペン書式解除 Rem 漢数字を検索し、文書から蛍光ペン書式25%灰色・水色を解除する。 Rem *----*----* *----*----* *----*----* *----*----* Dim myStartMarker As Word.Range ' Rem 検索開始点の取得。 Rem カーソルが文章の途中あると、不都合が起こるので、 Rem 文章の先頭に移動する。 Set myStartMarker = Selection.Range Selection.Sentences(1).Select Selection.Collapse wdCollapseStart ' Rem 洋数字・漢数字を1文字ずつ検索することを指定。 With Selection.Find .ClearFormatting .Text = "[0-9〇一二三四五六七八九十百千万億兆]{1,1}" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With ' myStrNumNoHighlightSubEntry: Selection.Find.Execute If Not Selection.Find.Found Then Rem 検索した文字列がない場合。 GoTo myStrNumNoHighlightSubExit End If ' Rem 検索した文字列がある場合。 Select Case Selection.Range.HighlightColorIndex Case wdGray25, wdTurquoise Selection.Range.HighlightColorIndex = wdNoHighlight End Select Selection.Collapse wdCollapseEnd ' GoTo myStrNumNoHighlightSubEntry myStrNumNoHighlightSubExit: Selection.Collapse wdCollapseEnd MsgBox "検索終了!" myStartMarker.Select ' 検索後、開始点に戻る。 End Sub ' myStrNumNoHighlight *----*----* *----*----* *----*----* *----*----*