アラビア数字を漢数字に変換する(2題)
                                                         玄関へお回り下さい。
アラビア数字←→漢数字に変換する(数字のみ半角・全角変換もOK)   (006)
   Option Explicit

Private Function
fKansujToArabia(ByVal MyString As String, _
                ByVal ChangeNo As Long) As String
  Dim Table(1 To 3) As String
  Dim Icount    As Long
  Dim Location   As Long
  Dim strTemp    As String
  strTemp = MyString
  Table(1) = "0123456789-0123456789−〇一二三四五六七八九ー"
  Table(2) = "0123456789−"
  Table(3) = "〇一二三四五六七八九ー"
  For Icount = 1 To Len(strTemp)
    Location = InStr(Table(1), Mid$(strTemp, Icount, 1))
    If Location Then
      Select Case ChangeNo
        Case 4     '半角だけ全角に(漢数字除く)
          If Location <= 12 Then
            Mid$(strTemp, Icount, 1) = Mid$(Table(2), Location, 1)
          End If
        Case 5     '全角だけ半角に(漢数字除く)
          If Location >= 12 And Location <= 22 Then
            Location = Location - 11
            Mid$(strTemp, Icount, 1) = Mid$(Table(1), Location, 1)
          End If
        Case 1 To 3   '1=全半角 2=全全角 3=全漢数字
          If Location >= 12 Then Location = Location - 11
          If Location >= 12 Then Location = Location - 11
          If Location >= 1 Then
            Mid$(strTemp, Icount, 1) = _
                  Mid$(Table(ChangeNo), Location, 1)
          End If
      End Select
    End If
  Next Icount
  fKansujToArabia = strTemp
End Function


Private Sub Command1_Click()
  On Error Resume Next
  Dim SelectNo As Long
  '文字列の入力チェック
  If Len(Trim$(Text1.Text)) = 0 Then
    Beep
    Exit Sub
  End If
  '長整数型に変換する
  SelectNo = CLng(Text3.Text)
  If Err.Number Then Beep: Exit Sub
  Text2.Text = fKansujToArabia(Text1.Text, SelectNo)
End Sub


Private Sub Text3_KeyPress(KeyAscii As Integer)
  ' 1〜5の範囲の入力制限
  If KeyAscii >= 32 And KeyAscii < 49 Or KeyAscii > 53 Then
    Beep           'エラー音
    KeyAscii = 0       '入力キーを無効にする
  End If
End Sub


     実行結果
   
住所等の数字を縦書き用の数字に変える場合又は数字だけを半角/全角に変換する場合等に便利かと思います。
処理としては1文字づつチェックして行き該当文字がテーブル1に見つかればその位置と同じ位置の変換用テーブルの文字と置き換えているだけです。
半角/全角の相互変換はStrConv関数でもできますが英数字とカタカナも同時に変換されます。
|文字はフォント等によっても違いますので適時変更して下さい。
又、(株)→株式会社→ 梶@等の文字も変換出来るようにして見て下さい。
使用例は簡略化していますので、実際はエラーチェック等を十分にして下さい。
数字を色んな漢数字に変換する(1234→壱阡弐百参拾四 他)
     まず、VBからExcel及びWordを操作する時の注意事項を見て下さい

Private Function fKansuji(ByVal lngArabicNumerals As Long, _
            ByVal lngSelectNo As Long) As String
  On Error Resume Next
  Dim xlApp  As Excel.Application
  Dim xlBook As Excel.Workbook
  Dim xlSheet As Excel.Worksheet
  'Set xlApp = New Excel.Application
  'こちらでも可(どちらがいいかは解かりません)
  Set xlApp = CreateObject("Excel.Application")
  Set xlBook = xlApp.Workbooks.Add
  Set xlSheet = xlBook.Worksheets.Add
  'セル(A1)に数値を挿入
  xlSheet.Cells(1, 1).Value = lngArabicNumerals
  'Formula プロパティを使ってセルに式を挿入します。
  Select Case lngSelectNo
    Case 1   '千二百三十四に変換
    xlSheet.Cells(1, 2).Formula = "=NUMBERSTRING(A1,1)"
    Case 2   '壱阡弐百参拾四に変換
    xlSheet.Cells(1, 2).Formula = "=NUMBERSTRING(A1,2)"
    Case 3   '一二三四に変換
    xlSheet.Cells(1, 2).Formula = "=NUMBERSTRING(A1,3)"
  End Select
  '変換結果を渡す
  fKansuji = xlSheet.Cells(1, 2)
  '保存時のダイログボックスを非表示に設定
  xlApp.DisplayAlerts = False
  'オブジェクトを解放します
  Set xlSheet = Nothing
  xlBook.Close      'Book を閉じる
  Set xlBook = Nothing
  xlApp.Quit       'Quit メソッドを使って Excel を終了します。
  Set xlApp = Nothing
End Function


Private Sub
Command2_Click()
  On Error Resume Next
  Dim lngNumber As Long
  Dim SelectNo As Long
  '長整数型に変換する
  lngNumber = CLng(Text4.Text)
  SelectNo = CLng(Text6.Text)
  '文字が混じっていたら
  If Err.Number Then Beep: Exit Sub
  Text5.Text = fKansuji(lngNumber, SelectNo)
End Sub


Private Sub Text4_KeyPress(KeyAscii As Integer)
  If KeyAscii >= 32 And KeyAscii < 48 Or KeyAscii > 57 Then
    Beep           'エラー音
    KeyAscii = 0       '入力キーを無効にする
  End If
End Sub


Private Sub Text6_KeyPress(KeyAscii As Integer)
  ' 1〜3の範囲の入力制限
  If KeyAscii >= 32 And KeyAscii < 49 Or KeyAscii > 51 Then
    Beep           'エラー音
    KeyAscii = 0       '入力キーを無効にする
  End If
End Sub
 

処理としては数字(数値)だけを取り出し、エクセルのNUMBERSTRING関数を使って漢数字に変換しているだけです。NUMBERSTRING関数はエクセルの隠し関数でヘルプにも載っていませんのであまり知られていないと思います。
最初の1回は少し時間がかかりますが次からは1秒以内で変換できるので使用には耐えられるかと思います。これをVBだけでやろうとすると相当複雑になるかと思います。
使用例は簡略化していますので、実際はエラーチェック等を十分にして下さい。




01/12/18