アラビア数字を漢数字に変換する(２題)
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　玄関へお回り下さい。
アラビア数字←→漢数字に変換する（数字のみ半角・全角変換も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-０１２３４５６７８９－〇一二三四五六七八九ー"
　　Table(2) = "０１２３４５６７８９－"
　　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)
　　' １～５の範囲の入力制限
　　If KeyAscii >= 32 And KeyAscii < 49 Or KeyAscii > 53 Then
　　　　Beep　　　　　　　　　　 'エラー音
　　　　KeyAscii = 0　　　　　　 '入力キーを無効にする
　　End If
End Sub


   　　実行結果
　　　
住所等の数字を縦書き用の数字に変える場合又は数字だけを半角／全角に変換する場合等に便利かと思います。
処理としては１文字づつチェックして行き該当文字がテーブル１に見つかればその位置と同じ位置の変換用テーブルの文字と置き換えているだけです。
半角／全角の相互変換はStrConv関数でもできますが英数字とカタカナも同時に変換されます。
｜文字はフォント等によっても違いますので適時変更して下さい。
又、（株）→株式会社→ ㈱　等の文字も変換出来るようにして見て下さい。
使用例は簡略化していますので、実際はエラーチェック等を十分にして下さい。
数字を色んな漢数字に変換する（１２３４→壱阡弐百参拾四　他）
　　　　 まず、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)
　　' １～3の範囲の入力制限
　　If KeyAscii >= 32 And KeyAscii < 49 Or KeyAscii > 51 Then
　　　　Beep　　　　　　　　　　 'エラー音
　　　　KeyAscii = 0　　　　　　 '入力キーを無効にする
　　End If
End Sub
　
処理としては数字（数値）だけを取り出し、エクセルのNUMBERSTRING関数を使って漢数字に変換しているだけです。NUMBERSTRING関数はエクセルの隠し関数でヘルプにも載っていませんのであまり知られていないと思います。
最初の１回は少し時間がかかりますが次からは１秒以内で変換できるので使用には耐えられるかと思います。これをVBだけでやろうとすると相当複雑になるかと思います。
使用例は簡略化していますので、実際はエラーチェック等を十分にして下さい。




01/12/18