洋々亭　文書処理・お仕事Tips

お仕事Tipsトップ >> Word：【漢数くん】漢数字マクロパック

■Word：【漢数くん】 - 漢数字マクロのパック

　「漢数くん」は、筆者が手抜き用に作ったWordのマクロをまとめたものです。

　簡単な起動ランチャが付いていますので、個々のマクロごとに起動するより簡単です。

　機能の中心は、漢数字処理ですが、法令の目次作成や法令形式書式設定などは、作業時間の短縮に意外と重宝するかも。

　なお、作成時期がばらばらのため、コードは統一性がないのでご容赦ください。(^ ^;)

【改変履歴】

・2012/2/26:Ver1.3にバージョンアップ（変換バグ暫定修正）

・2011/1/10:Ver1.2にバージョンアップ（万億兆の変換バグ修正）

■「漢数くん」の機能

漢数字を算用数字（アラビア数字）に変換　：
　こちらの漢数字⇒算用数字変換マクロと同じですが、漢数くんからは、カンマの有無や万億表記の有無を選択できます。指定範囲だけの変換もできます。
算用数字を漢数字に変換　：
　上記の逆です。こちらの算用数字⇒漢数字変換マクロと同じですが、漢数くんからは、万億表記の有無を選択できます。指定範囲だけの変換もできます。
HTML書式・リンク解除　：
　ネットのサイトのページをWordに貼り付けたときに、HTMLの書式やリンクを解除できます。 HTML書式・リンク解除マクロと同じです。

法令形式書式設定　：
　ベタ組の法令を、条・項・号に応じて段下げします。条はゴシック体に書式設定します。

→

法令の目次の生成　：
法令の条見出しから、目次を生成します。他市の条例で目次のない法令の構成を調べるときなどに重宝します。

■マクロコードの登録について

下記のマクロコードをコピーします。
（コードの下の [ コードを全選択 ] をクリックすると選択状態になるので、コードを右クリックして、ポップアップメニューの[コピー]を選びます。）
Wordで新規文書を起動し、ショートカットキー　 Alt ＋　F11 　でマクロ編集画面（VBA ：右図）を開きます。
VBAの左側のペインで、Normalの標準モジュールの中のModule1を選択します。
　※　もし、Normalの中に標準モジュールがない場合は、Normalを右クリックし表示されるメニューから[挿入]⇒[標準モジュール]をクリックして追加します。
コード欄にコピーしたコードを貼り付けます。
　　（詳細：Wordマクロコードの登録方法）
そのマクロに不安があったら：
ネットからコピーしたコードには、ウイルスが潜んでいる可能性があります。不安があったら、空白文書にいったん保存し、そのファイルを「Wordで開く前に」ワクチンソフトでチェックしてから利用しましょう。（個別文書に登録し、ウイルスと作動チェックを行う方法）

Option Explicit

Sub 漢数くん()
'------------------------------------------------------------------------
' 【漢数くん　ver.1.3】 - 洋々亭Wordマクロ・ランチャ
'　作成者　洋々亭 2004-2012 (c)
'------------------------------------------------------------------------
' ネットからコピーした法律・条例などの法令テキストを利用しやすくするため、
' 漢数字⇒英数字、書式変換などのマクロを管理するランチャ
'●作動条件
'  Microsoft Word 2002～2010
'------------------------------------------------------------------------
  Dim sitem As String, item As Long
  
  sitem = InputBox("1：漢数字→英数字：カンマなし (例：3万6000円)" & vbCrLf & _
      "2：漢数字→英数字：カンマ付 　(例：3万6,000円)" & vbCrLf & _
      "3：漢数字→英数字：万億なし 　(例：36,000円)" & vbCrLf & _
      " 　----------------------------------------" & vbCrLf & _
      "4：英数字→漢数字：桁漢字付　 (例：三万六千円)" & vbCrLf & _
      "5：英数字→漢数字：桁漢字なし (例：三六、○○○円)" & vbCrLf & _
      " 　----------------------------------------" & vbCrLf & _
      "6：HTML書式・リンク解除" & vbCrLf & _
      " 　----------------------------------------" & vbCrLf & _
      "7：法令形式書式設定（段下げ、条ゴシック）" & vbCrLf & _
      "8：法令の条と見出しから目次を生成" & vbCrLf & _
       "　　　※　１～５は、範囲を指定しても処理可能です。" & vbCrLf & _
       vbCrLf & "　　　▼ 処理番号を半角数字で入力してください。" _
       , "漢数くん Ver1.2：洋々亭Wordマクロ集 - １", 1)
  item = Val(sitem)
  Select Case item
    Case 1    '漢数字→英数字：カンマなし (例：3万6000円)
      Call 漢数字to算用数字変換
    Case 2    '漢数字→英数字：カンマ付 (例：3万6,000円)
      Call 漢数字to算用数字変換(0, 1)
    Case 3    '漢数字→英数字：万億なし (例：36,000円)
      Call 漢数字to算用数字変換(1, 1)
    Case 4    '英数字→漢数字：桁区切 (例：三万六千円)
      Call 算用to漢数字変換
    Case 5    '英数字→漢数字：桁なし (例：三六、○○○円)
      Call 算用to漢数字変換(1)
    Case 6    'HTML書式・リンク解除
      Call HTML書式解除
    Case 7    '法令形式書式設定（段下げ、条ゴシック）
      Call dansage
    Case 8    '：条と見出しから目次を作成
      Call mokuji
    Case Else
      MsgBox "処理番号を数字で入力してください"
  End Select
End Sub

Sub 漢数字to算用数字変換(Optional flgMans As Long, _
    Optional flgCom As Long)
'----------------------------------------
'MS-Word用マクロ：漢数字を英数字に変換
'作成者　洋々亭 2006-2012
'2012/02/26:  Ver0.6 ' 暫定修正
'2011/01/10:  Ver0.5
'2010/10/04:  Ver0.4
'○使うサブルーチン：
'    function conv2num(skan,[numform],[setcom])
'    function subconv2num(skan)  ' conv2num()のサブルーチン
'----------------------------------------
  Const NOCOM = 0   'コンマ不使用(規定値)
  Const COMMA = 1   'コンマ使用
  Const MIXNUM = 0  '万億兆を混在（3万6000）
  Const PURENUM = 1 '万億兆は不使用。（36,000)

'  Dim flgMans As Long ' 0…4桁区切りを入れる(32万6,500円)／1…入れない(326,500円)
'  Dim flgCom As Long  ' 0…カンマを使わない(2700万円)／1…使うわない(2,700万円)
  Dim str As String, kcketa As String, buf As String
  Dim ileng As Long
  Dim unit As String, headunit As String, piriunit As String, mansunit As String
  Dim sKancom As String ' 「、」をカンマとみなすかどうか設定
  Dim myRange As Range, para As Paragraph
  Dim RE As Object, RE2 As Object, Matches As Object, Match As Object
  Dim bugbuf
  Set RE = CreateObject("VBScript.RegExp")
  Set RE2 = CreateObject("VBScript.RegExp")
  RE.Global = False   'True:全ての検索結果を処理、False:初出の結果のみ処理
  RE2.Global = False
  
' -----------------  変換設定フラグ（不要な方をコメントアウト）----------
   'flgMansの設定：(漢数くん使用時は引数使用)
'  flgMans = MIXNUM    '0(MIXNUM)…万億兆を混在（3万6000）
'  flgMans = PURENUM  ' 1(PURENUM)…万億兆は不使用(36,000)
   
   'flgComの設定：(漢数くん使用時は引数使用)
'  flgCom = NOCOM  '0(NOCOM)…カンマを使わない(2700万円)
'  flgCom = COMMA   '1(COMMA)…使う(2,700万円)
  
   'sKancom設定：
  sKancom = ""  '[ = "" ]で、句読点をカンマとみなさない。
'  sKancom = "、"  '[ ="、" ]で、句読点をカンマとみなす。
     
' ------------------------------------------------------------------------

   ' 変換単位（複数文字可）
  unit = "(・|\.|人|名|円|年|月|日|時|分|秒|世紀|章|節|条|項|号|目|款|歳|番|番地" & _
    "|点|匹|頭|羽|冊|本|枚|台|機|回|軒|件|県|審|間|世帯|米|平方|立方" & _
    "|以上|以下|未満|を超え" & _
    "|キロ|メガ|トン|メートル|センチ|ミリ|マイクロ|ミクロン|ヤード|ポンド|インチ|エーカー" & _
    "|リットル|ガロン|ヘクト|パーセント|ベクレル|シーベルト|グレイ|ドル|ユーロ|元|ウォン" & _
    "|\%|％|cm|ｃｍ|Cm|Ｃｍ|℃|μ|m|ｍ|M|Ｍ|k|ｋ|K|Ｋ|Sv|Ｓｖ|Bq|Ｂｑ|Gy|Ｇｙ" & _
    "|光年|パーセク|ー)"
   ' 頭部変換単位（複数文字可）
  headunit = "(問|問題|人口|第|マッハ|ワープ|セシウム|カリウム|ヨウ素|炭素|ウラン|ストロンチウム)"
  mansunit = "(京|兆|億|万)"
   ' ピリオド単位
  piriunit = "(・|\.)"
  
   ' 変換範囲（段落=paragraph単位で変換）
  If Selection.Start = Selection.End Then
    Set myRange = ActiveDocument.Range   '範囲選択しなければ文書全体
  Else
    Set myRange = Selection.Range    '選択された範囲内の段落のみ
  End If
  
  For Each para In myRange.Paragraphs
      ' 文書を一気に変換すると表が解除されるのでパラグラフごとに変換
      ' 途中でパラグラフを移動させないため、文字列bufにコピーして作業
    buf = para.Range.Text
    
      '「**条『の**』」、「百分『の五十』」の部変換
    RE.Pattern = "([〇○一二三四五六七八九十百千]+)" & _
       "([章|節|条|項|分]の)([〇○一二三四五六七八九十百千]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(0), flgMans, flgCom)
        str = str & Matches(0).SubMatches(1)
        str = str & conv2num(Matches(0).SubMatches(2), flgMans, flgCom)
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      '条・項・号変換
    RE.Pattern = "第([一二三四五六七八九十百千]+)(章|節|条|項|号)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(0), flgMans, flgCom)
        str = "第" & str & Matches(0).SubMatches(1)
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
          '小数点「・」以下変換　(十百千の桁文字持たないことが前提)
    RE.Pattern = piriunit & "([〇○一二三四五六七八九]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(1), flgMans, NOCOM)
        str = "." & str
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      '「**人、**円、**年**月**日」部変換
      '2011/01/10：「二十万円」等で無限ループになるバグ修正
      '2012/02/26: 「一時的」などで無限ループになるバグの暫定修正
      '           （RE.Pattern、SubMatches(N)を変更）
    RE.Pattern = "(([〇○一二三四五六七八九十百千" & sKancom & "]+[万億兆京]*)+)" & unit
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
            str = conv2num(Matches(0).SubMatches(0), flgMans, flgCom)
            str = str & Matches(0).SubMatches(2)  '単位結合
            RE2.Pattern = Matches(0).Value
            buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      '「問**、マッハ**、ワープ**」など、頭部単位変換
    RE.Pattern = headunit & "([〇○一二三四五六七八九十百千]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(1), flgMans, flgCom)
        str = Matches(0).SubMatches(0) & str  '単位結合
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
    
' 行頭の「○３」を「③」に変換。この機能を使いたい場合は、
' 次の行から、End Ifまでのコメント「'」を外してください。

'    RE.Pattern = "^○[０１２３４５６７８９]+"
'    Do
'      Set Matches = RE.Execute(buf)
'      If Matches.Count > 0 Then
'        ileng = Matches(0).Length
'        str = marumoji(Matches(0).Value, ileng)
'        RE2.Pattern = Matches(0).Value
'        buf = RE2.Replace(buf, str)
'      End If
'    Loop Until Matches.Count = 0

      ' 作業bufが変更されていたら、paragraph置き換え
    If buf <> para.Range.Text Then
      para.Range.Text = buf
    End If
  Next
  Set RE = Nothing
  Set Matches = Nothing
  Set Match = Nothing
  Set myRange = Nothing
End Sub
  
Function conv2num(skan As String, _
    Optional numform As Long, _
    Optional setcom As Long) As String
'------------------------------------------------------------------
' ○conv2num関数 ：漢数字の文字列を英数字の文字列に変換する。
'作成者　洋々亭 2010
' 2010/9/20  Ver0.1  全面書換え。万億兆京含む変換。千位はsubconv2num()呼び出し変換
' 2010/10/4  ver0.12 ロジック整理
' ○引数
'   skan  ：処理する漢数字（「五十万千七百五」,「五○一七〇五」どちらも可）
'   numform ：0(MIXNUM)…(規定値)万億兆京の表示／1(PURENUM)…算用数字のみ
'   setcom  ：0(NOCOM)…(規定値)カンマ不使用／1(COMMA)…3桁ごとにカンマ入れる
' ○戻り値
'   変換結果の文字列
' ○使うサブルーチン
'    function subconv2num(skan)
'------------------------------------------------------------------
  Const NOCOM = 0   'コンマ不使用(規定値)
  Const COMMA = 1   'コンマ使用
  Const MIXNUM = 0  '万億兆を混在（3万6000）
  Const PURENUM = 1 '万億兆は不使用。（36,000)
  Dim i As Long, ileng As Long, ipos As Long
  Dim swork As String, sbuf As String, buf As String, sdot As String
  Dim skei As String, styo As String, soku As String, sman As String, ssen As String
  Dim kkei As String, ktyo As String, koku As String, kman As String
  Dim RE As Object, Matches As Object
  Set RE = CreateObject("VBScript.RegExp")
  RE.Global = True   'True:全ての検索結果を処理、False:初出の結果のみ処理

  swork = skan
  ' 万億兆京が無い漢数字の場合（万未満、または「三○五八七」など）
  RE.Pattern = "[万億兆京]"
  Set Matches = RE.Execute(swork)
  If Matches.Count = 0 Then
    sbuf = subconv2num(swork)
    If setcom = COMMA Then
      sbuf = Format(sbuf, "#,###")
    End If
    conv2num = sbuf
    Exit Function
  End If
  
  ' 万以上の漢数字が存在する場合
  ipos = InStr(swork, "京")    '京の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '京の数字
    skei = subconv2num(buf)
    swork = Right(swork, Len(swork) - ipos)   '京未満部分
    kkei = "京"
  Else
    skei = "": kkei = ""  'この桁が存在しないときは空白を接続
  End If
  ipos = InStr(swork, "兆")    '兆の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '兆の数字
    styo = subconv2num(buf)
    styo = Format(styo, "0000")
    swork = Right(swork, Len(swork) - ipos)  '兆未満部分
    ktyo = "兆"
  Else
    styo = "0000": ktyo = ""
  End If
  ipos = InStr(swork, "億")    '億の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '億の数字
    soku = subconv2num(buf)
    soku = Format(soku, "0000")
    swork = Right(swork, Len(swork) - ipos)   '億未満部分
    koku = "億"
  Else
    soku = "0000": koku = ""
  End If
  ipos = InStr(swork, "万")    '万の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '万の数字
    sman = subconv2num(buf)
    sman = Format(sman, "0000")
    swork = Right(swork, Len(swork) - ipos)   '万未満部分
    kman = "万"
  Else
    sman = "0000": kman = ""
  End If
  If swork = "" Then
    ssen = "0000"    '万以下の部分がないとき0で埋め
  Else
    ssen = subconv2num(swork)   '万未満の数字
    ssen = Format(ssen, "0000")
  End If
  
        ' ※　関数Format( x , "#,###" )は、x = 0 のとき、空白を返す。
  If numform = PURENUM Then   ' 万億兆使わない指定のとき(例：6,543,210)
    sbuf = skei & styo & soku & sman & ssen
    sbuf = Format(sbuf, "#,###")
  Else
    If setcom = COMMA Then
      sbuf = Format(skei, "#,###") & kkei & Format(styo, "#,###") & ktyo & _
      Format(soku, "#,###") & koku & Format(sman, "#,###") & kman & Format(ssen, "#,###")
    Else
      sbuf = Format(skei, "####") & kkei & Format(styo, "####") & ktyo & _
      Format(soku, "####") & koku & Format(sman, "####") & kman & Format(ssen, "####")
    End If
  End If
  conv2num = sbuf
  Exit Function
End Function

Function subconv2num(skan As String) As String
'------------------------------------------------------------------
' ○subconv2num関数 ：漢字4桁（千百十一位）を算用数字に変換して返すサブ関数
'作成者　洋々亭 2010
' 2010/9/20  Ver0.1
' ○引数
'   skan  ：処理する漢数字（「二千七百五」,「二、七〇五」どちらも可）
' ○戻り値
'   変換結果の文字列（ex:二千七百五　→　2705）
'------------------------------------------------------------------
  Const KANopNUM = "〇○一二三四五六七八九、・"  '桁漢字無(ピリオド付）
  Const KANNUM = "一二三四五六七八九"     '桁漢字付き用
  Const KANKETA = "十百千"         '桁漢字（千まで）
  Const ALpNUM = "00123456789,."       '英数字（ピリオド付）
  Dim i As Long, ileng As Long, cnt As Long, iketa As Long, skpflg As Long
  Dim pos As Long, san As Long
  Dim kcsu As String, sbuf As String
  
  iketa = 1     '現在処理中の英数字の桁数
  sbuf = ""
  '桁漢字 [十百千] の有無で処理を分岐
  cnt = 0
  ileng = Len(skan)
  pos = ileng    'pos:漢字文字列中の処理中文字ポインタ
  For i = 1 To ileng
    cnt = cnt + InStr(KANKETA, Mid(skan, i, 1))
  Next
  If cnt = 0 Then
    '桁漢字を使わない表記の場合（例：二、七〇五）
    For i = 1 To ileng
      kcsu = Mid(skan, i, 1)
      sbuf = sbuf & Mid(ALpNUM, InStr(KANopNUM, kcsu), 1)
    Next
    sbuf = Replace(sbuf, ",", "") 'カンマ削除
  Else
    '桁漢字を使う表記の場合（例：二千七百五）
    Do
      skpflg = 0
      kcsu = Mid(skan, pos, 1)
      san = InStr(KANNUM, kcsu)
      If iketa > 1 Then
        If kcsu = Mid(KANKETA, iketa - 1, 1) Then
          pos = pos - 1
          If pos < 1 Then
            sbuf = "1" & sbuf
            Exit Do
          End If
          kcsu = Mid(skan, pos, 1)
          san = InStr(KANNUM, kcsu)
        Else
          sbuf = "0" & sbuf
          iketa = iketa + 1
          skpflg = 1
        End If
      End If
      If skpflg = 0 Then
        If san = 0 Then
          If iketa = 1 Then
            sbuf = "0"
          Else
            sbuf = "1" & sbuf
          End If
          iketa = iketa + 1
        Else
          sbuf = san & sbuf
          iketa = iketa + 1
          pos = pos - 1
        End If
      End If
    Loop While iketa <= 4 And pos > 0
  End If
  subconv2num = sbuf
  Exit Function
End Function

Function marumoji(skan As String, ileng) As String
'---------------------------------------------------------------------
' 作成者　洋々亭 2006
' ○marumoji関数 ：「○３」形式の標記を「③」に変換する。
' ○引数
'     skan  ：処理する漢数字（例：「○３」,「○１２」）
'     ileng ：処理する文字列の長さ（「○１２」なら3)
' ○戻り値
'     変換結果の文字列（○２０以上は[21]のように変換）
'---------------------------------------------------------------------

    Dim skcsan As String, sansu As String, smarusu As String
    Dim kcsu As String, sbuf As String
    Dim i, cnt
    skcsan = "０１２３４５６７８９"         '桁漢字有り用
    sansu = "0123456789"                    '桁漢字無し用置き換え英数字
    smarusu = "①②③④⑤⑥⑦⑧⑨⑩⑪⑫⑬⑭⑮⑯⑰⑱⑲⑳"    '丸付数字
    sbuf = ""
    For i = 2 To ileng
        kcsu = Mid(skan, i, 1)
        sbuf = sbuf & Mid(sansu, InStr(skcsan, kcsu), 1)
    Next
    cnt = Val(sbuf)
    If cnt > 20 Or cnt = 0 Then
        marumoji = "[" & sbuf & "]"
    Else
        marumoji = Mid(smarusu, cnt, 1)
    End If
    Exit Function
End Function

Sub 算用to漢数字変換(Optional flgketa As Long)
'------------------------------------------------------------------------
'テキストの英数字を漢数字に変換（半角0-9、全角０-９いずれも可）
'作成者　洋々亭 2006-2010
' 2006/8/27  Ver0.1
' 2010/10/4  ver0.4 ロジック整理
'○呼び出すサブルーチン：
'  ①conv2kan(skan, setketa)
'     ※setketa:1(KETAMOJI)で桁文字（十百千）使用、0(NOKETA)で桁文字不使用
'------------------------------------------------------------------------
'
  Const KETAMOJI = 0  ' 七千三十五
  Const NOKETA = 1    ' 七○三五
'  Dim flgketa As Long
   ' flgketa設定：(漢数くん使用時は引数使用)
   ' 0(KETAMOJI)…千百十使う。／0(NOKETA)…千百十使わない
  Dim str As String
  Dim piriunit As String
  Dim strbuf As String, pstr As String
  Dim RE As Object, RE2 As Object, Matches As Object, Match As Object
  Dim myRange As Range
  Dim para As Paragraph
  Dim buf As String
  Set RE = CreateObject("VBScript.RegExp")
  Set RE2 = CreateObject("VBScript.RegExp")
  RE.Global = False   'True:全ての検索結果を処理、False:初出の結果のみ処理
  RE2.Global = False
   
    ' ピリオド単位
  piriunit = "(．|\.)"
  
    ' 変換範囲（段落：paragraph単位で変換）
  If Selection.Start = Selection.End Then
    Set myRange = ActiveDocument.Range   '範囲選択しなければ文書全体
  Else
    Set myRange = Selection.Range    '選択された範囲内の段落のみ
  End If
  
  For Each para In myRange.Paragraphs
      ' 途中でパラグラフを移動させないため、文字列bufにコピーして作業
    buf = para.Range.Text
    
    ' 先に小数点[．|.]以下を変換（「三○五四」のようにベタ変換）
    RE.Pattern = piriunit & "([0-9]+|[０１２３４５６７８９]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2kan(Matches(0).SubMatches(1), NOKETA)
        str = "・" & str
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
   
    '「NN,NNN,NNN,NNN ／　N,NNN億、N,NNN万」変換
    RE.Pattern = "([0-9,]+|[０１２３４５６７８９，]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        strbuf = Replace(Matches(0).SubMatches(0), ",", "") 'カンマ削除
        str = ""
        If Len(strbuf) > 16 Then
          pstr = Left(strbuf, Len(strbuf) - 16)
          str = conv2kan(pstr, flgketa) & "京"
          strbuf = Right(strbuf, 16)
        End If
        If Len(strbuf) > 12 Then
          pstr = Left(strbuf, Len(strbuf) - 12)
          str = conv2kan(pstr, flgketa) & "兆"
          strbuf = Right(strbuf, 12)
        End If
        If Len(strbuf) > 8 Then
          pstr = Left(strbuf, Len(strbuf) - 8)
          str = str & conv2kan(pstr, flgketa) & "億"
          strbuf = Right(strbuf, 8)
        End If
        If Len(strbuf) > 4 Then
          pstr = Left(strbuf, Len(strbuf) - 4)
          str = str & conv2kan(pstr, flgketa) & "万"
          strbuf = Right(strbuf, 4)
        End If
        If Len(strbuf) > 0 Then
          pstr = strbuf
          str = str & conv2kan(pstr, flgketa)
        End If
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      ' 作業bufが変更されていたら、paragraph置き換え
    If buf <> para.Range.Text Then
      para.Range.Text = buf
    End If
  Next
  Set RE = Nothing
  Set Matches = Nothing
  Set Match = Nothing
  Set myRange = Nothing
End Sub

Function conv2kan(ssan As String, Optional setketa As Long) As String
'
'---------------------------------------------------------------------
' conv2kan関数 ：英数字の文字列を漢数字の文字列に変換する。
' 作成者　洋々亭 2006-2010
' ○引数
'     ssan  ：処理する英数字（「0-9」,「０-９」どちらも可）
'     setketa：1(KETAMOJI)で桁文字（十百千）使用、0(NOKETA)で桁文字不使用
' ○戻り値
'     変換結果の文字列
'---------------------------------------------------------------------
'
    Const KETAMOJI = 0
    Const NOKETA = 1
    Const ALwpNUM = "０１２３４５６７８９，．"
    Const ALpNUM = "0123456789,."
    Const KANKETA2 = "一十百千"     '桁漢字（一～千)
    Const KANNUM = "一二三四五六七八九"  '桁漢字あり用
    Const KANopNUM = "〇一二三四五六七八九、・"  '桁漢字無(ピリオド付き）
    Dim sbuf As String, swork As String
    Dim ileng As Long
    Dim iketa As Long, pos As Long, i As Long, cnt As Long
    
    ileng = Len(ssan)
    pos = ileng      'pos:漢字文字列中の処理中文字ポインタ
    iketa = 1       '現在処理中の英数字の桁数
    '全部半角に変換
    swork = ""
    pos = 0
    For i = 1 To ileng
      pos = InStr(ALwpNUM, Mid(ssan, i, 1))
      If pos > 0 Then
        swork = swork & Mid(ALpNUM, pos, 1)
      Else
        swork = swork & Mid(ssan, i, 1)
      End If
    Next
    sbuf = ""
    If setketa = NOKETA Then
      '桁漢字を使わない表記の場合（例：一七〇五）
      For i = 1 To ileng
        cnt = InStr(ALpNUM, Mid(swork, i, 1))
        sbuf = sbuf & Mid(KANopNUM, cnt, 1)
      Next
      conv2kan = sbuf
      Exit Function
    Else
      '桁漢字を使った表記の場合 （例：千七百五）
      swork = Replace(swork, ",", "") 'カンマ削除
      iketa = 1           '現在処理中の英数字の桁数
      ileng = Len(swork)      '文字列長再取得
      For i = ileng To 1 Step -1
        cnt = Val(Mid(swork, i, 1))
        If cnt = 1 Then
          sbuf = Mid(KANKETA2, iketa, 1) & sbuf
        ElseIf cnt >= 2 And cnt <= 9 Then
          If iketa = 1 Then
            sbuf = Mid(KANNUM, cnt, 1) & sbuf
          Else
            sbuf = Mid(KANKETA2, iketa, 1) & sbuf
            sbuf = Mid(KANNUM, cnt, 1) & sbuf
          End If
        End If
        iketa = iketa + 1
      Next
    End If
    conv2kan = sbuf
    Exit Function
End Function
                        
Sub HTML書式解除()
'
'--------------------------------------------------------
' 文書内のハイパーリンクを解除、書式を規定値に設定
' 作成者　洋々亭 2006
'--------------------------------------------------------
  Dim aTable As Table, chgrng As Range, aField As Field, pos As Long
    '注）Wordはフィールドでリンクを設定している
  For Each aField In ActiveDocument.Fields
    aField.Unlink
  Next
    'HTML文書全体の書式をクリア
  Selection.WholeStory
  Selection.ClearFormatting
    '表（テーブル）の罫線を実線（格子）に変更し
  For Each aTable In ActiveDocument.Tables
    With aTable
      .Style = "表 (格子)"
      .ApplyStyleHeadingRows = False
      .ApplyStyleLastRow = False
      .ApplyStyleFirstColumn = False
      .ApplyStyleLastColumn = False
      .Rows.LeftIndent = MillimetersToPoints(4)   '左から4mmに配置
      .PreferredWidthType = wdPreferredWidthPercent '幅指定は%単位
      .PreferredWidth = 96  '表の幅を文書幅の96%に変更
    End With
      '漢数字変換のときエラーが出るので表の前に改行挿入
    pos = aTable.Range.Start
    pos = pos - 1
    Set chgrng = aTable.Range
    chgrng.SetRange Start:=pos, End:=pos
    chgrng.InsertParagraphBefore
  Next
End Sub
            
Function mokuji()
'------------------------------
'作成者　洋々亭 2004
'条文と見出しを抽出し目次を作る
'例： 第１条（目的）
'     第２条（対象）
'------------------------------
  Dim sjouchr As String, sexp As String, str As String, sbuf As String
  Dim iflg As Long
  Dim RE As Object, Matches As Object
  Dim para As Paragraph
  sjouchr = "([一二三四五六七八九十百千]|[0-9]|[０１２３４５６８７９])"
  Set RE = CreateObject("VBScript.RegExp")
  RE.Global = False   'Global=Falseは、初出の結果のみ処理
  iflg = 0  '1のとき()付き見出しを保持中
    '段落ごとに調査
  For Each para In ActiveDocument.Paragraphs
    If iflg = 0 Then
        '（）付き説明を保持していないとき
      RE.Pattern = "^\s*(（|\()\W+(\)|）)"  '\Wは(1)等避け用
      Set Matches = RE.Execute(para.Range)
      If Matches.Count > 0 Then
        sexp = Matches(0).Value
        iflg = 1
      Else
        sexp = ""
      End If
    End If
    RE.Pattern = "^第" & sjouchr & "+条(の" & sjouchr & "+)*"
    Set Matches = RE.Execute(para.Range)
    If Matches.Count > 0 Then
      str = Matches(0).Value
      If iflg = 1 Then
        sbuf = sbuf & str & " " & sexp & vbCrLf
        sexp = ""
        iflg = 0
      Else
        sbuf = sbuf & str & vbCrLf
        iflg = 0
        sexp = ""
      End If
    End If
  Next
    '文書の頭に抜き出した目次を挿入
  With ActiveDocument.Content
    .InsertParagraphBefore
    .InsertBefore sbuf
  End With
  Set RE = Nothing
  Set Matches = Nothing
End Function

Function dansage()
'------------------------------
'作成者　洋々亭 2005
'法令文の段下げと文字強調
'○（目的）第１条　ゴシック体
'○法令横書き用段下げ
'------------------------------
  Dim sjouchr As String, skcsan As String, skansu As String, pos As Long
  Dim RE As Object, Matches As Object
  Dim para As Paragraph, chgrng As Range
  skcsan = "０１２３４５６７８９"
  skansu = "一二三四五六七八九十百千"
  Set RE = CreateObject("VBScript.RegExp")
  RE.Global = False   'Global=Falseは、初出の結果のみ処理
    '段落ごとに調査
  For Each para In ActiveDocument.Paragraphs
        '（）付き見出しを一文字インデント
    RE.Pattern = "^(（|\().+(\)|）)( |　)*"
    Set Matches = RE.Execute(para.Range)
    If Matches.Count > 0 Then
      para.Range.ParagraphFormat.FirstLineIndent = MillimetersToPoints(3.7)
        '括弧見出しをゴシック体に変換
      pos = para.Range.Start
      pos = pos + Matches(0).FirstIndex
      Set chgrng = para.Range
      chgrng.SetRange Start:=pos, End:=pos + Matches(0).Length
      chgrng.Font.Name = "ＭＳ ゴシック"
    Else
      RE.Pattern = "^第([" & skcsan & "]|[0-9]|[" & skansu & "])+条(の([" & skcsan & "]|[0-9]|[" & skansu & "])+)*"
      Set Matches = RE.Execute(para.Range)
      If Matches.Count > 0 Then
        With para.Range.ParagraphFormat
          .LeftIndent = MillimetersToPoints(3.7)
          .FirstLineIndent = MillimetersToPoints(-3.7)
          .SpaceBeforeAuto = False
          .SpaceAfterAuto = False
        End With
          '条をゴシック体に変換
        pos = para.Range.Start
        pos = pos + Matches(0).FirstIndex
        Set chgrng = para.Range
        chgrng.SetRange Start:=pos, End:=pos + Matches(0).Length
        chgrng.Font.Name = "ＭＳ ゴシック"
      End If
        '「項」
      RE.Pattern = "^([" & skcsan & "]+)|^([0-9]+)( |　)"
      Set Matches = RE.Execute(para.Range)
      If Matches.Count > 0 Then
        With para.Range.ParagraphFormat
          .LeftIndent = MillimetersToPoints(3.7)
          .FirstLineIndent = MillimetersToPoints(-3.7)
          .SpaceBeforeAuto = False
          .SpaceAfterAuto = False
        End With
      End If
        '「号」一段下げ
      RE.Pattern = "^[" & skansu & "]+( |　)"
      Set Matches = RE.Execute(para.Range)
      If Matches.Count > 0 Then
        With para.Range.ParagraphFormat
          .LeftIndent = MillimetersToPoints(7.4)
          .SpaceBeforeAuto = False
          .SpaceAfterAuto = False
          .FirstLineIndent = MillimetersToPoints(-3.7)
        End With
      End If
        '「ア～」２段下げ
      RE.Pattern = "^[ア-ン]+( |　)"
      Set Matches = RE.Execute(para.Range)
      If Matches.Count > 0 Then
        With para.Range.ParagraphFormat
          .LeftIndent = MillimetersToPoints(11.1)
          .SpaceBeforeAuto = False
          .SpaceAfterAuto = False
          .FirstLineIndent = MillimetersToPoints(-11.1)
          .FirstLineIndent = MillimetersToPoints(-3.7)
        End With
      End If
    End If
  Next
  Set RE = Nothing
  Set Matches = Nothing
End Function

'
' ================== End of Code =======================

「漢数くん」の起動

マクロ実行ダイアログから実行：
Wordを起動し、ショートカットキー　 Alt ＋　F８　でマクロ実行ダイアログを開きます。
　
ボタンやメニューに登録して実行：
　漢数くんを他の文書や新規文書でも使いたいときは、共用マクロ登録を行い、メニューやツールバーに登録しておくと、ワンタッチで起動できて便利です。Word2010からは、右図のようにリボンにも登録できるようになりました。
　　※　共用マクロ登録の方法はこちらを参照
マクロを強制終了したい場合は、慌てないで[ Ctrl ] + [ Break ]

このマクロはフリーソフトとし、取扱いはGPLに準拠します。
ただし、他のマクロに組み込んだり、その他の方法で、他に配布する場合は原作著作表示を残していただけるとうれしいです。
作者はこのマクロ及び本ドキュメントを使用した結果について何ら責任を負いません。