ローマ字をカタカナにする

2017/01/21 bongtengmaru VBA 2

ローマ字をカタカナにするVBAマクロ

メールアドレスのソーティング等に活用できる

引用元) http://park11.wakwak.com/~miko/Excel_Note/15-03_celldata.htm#15-03-57

VBA ローマ字(アルファベット)をカタカナに変換する
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
Function roma2kana(ByVal roma As String, Optional ByVal katakana As Boolean = True) As String
Dim i As Integer, j1 As Integer, j2 As Integer, k As Integer, index As Integer
Dim conv2 As Variant, conv1 As Variant, conv0 As Variant
Dim kanatbl(1 To 41), Pre As String
Dim retStr As String
conv2 = Array("by", "ch", "dy", "gy", "hy", "jy", "ky", "ly", "my", "nn", "ny", "py", "ry", "sh", "sy", "ts", "ty", "xy", "zy", "lt", "xt")
conv1 = Array("b", "d", "f", "g", "h", "j", "k", "l", "m", "n", "p", "r", "s", "t", "v", "w", "x", "y", "z")
conv0 = Array("a", "i", "u", "e", "o")
kanatbl(1) = Array("ア", "イ", "ウ", "エ", "オ")
kanatbl(2) = Array("バ", "ビ", "ブ", "ベ", "ボ")
kanatbl(3) = Array("ダ", "ヂ", "ヅ", "デ", "ド")
kanatbl(4) = Array("ファ", "フィ", "フ", "フェ", "フォ")
kanatbl(5) = Array("ガ", "ギ", "グ", "ゲ", "ゴ")
kanatbl(6) = Array("ハ", "ヒ", "フ", "ヘ", "ホ")
kanatbl(7) = Array("ジャ", "ジ", "ジュ", "ジェ", "ジョ")
kanatbl(8) = Array("カ", "キ", "ク", "ケ", "コ")
kanatbl(9) = Array("ァ", "ィ", "ゥ", "ェ", "ォ")
kanatbl(10) = Array("マ", "ミ", "ム", "メ", "モ")
kanatbl(11) = Array("ナ", "ニ", "ヌ", "ネ", "ノ")
kanatbl(12) = Array("パ", "ピ", "プ", "ペ", "ポ")
kanatbl(13) = Array("ラ", "リ", "ル", "レ", "ロ")
kanatbl(14) = Array("サ", "シ", "ス", "セ", "ソ")
kanatbl(15) = Array("タ", "チ", "ツ", "テ", "ト")
kanatbl(16) = Array("ウ゛ァ", "ウ゛ィ", "ウ゛", "ウ゛ェ", "ウ゛ォ")
kanatbl(17) = Array("ワ", "ヰ", "ウ", "ヱ", "ヲ")
kanatbl(18) = Array("ァ", "ィ", "ゥ", "ェ", "ォ")
kanatbl(19) = Array("ヤ", "イ", "ユ", "イェ", "ヨ")
kanatbl(20) = Array("ザ", "ジ", "ズ", "ゼ", "ゾ")
kanatbl(21) = Array("ビャ", "ビィ", "ビュ", "ビュ", "ビョ")
kanatbl(22) = Array("チャ", "チ", "チュ", "チェ", "チョ")
kanatbl(23) = Array("ヂャ", "ヂィ", "ヂュ", "ヂェ", "ヂョ")
kanatbl(24) = Array("ギャ", "ギィ", "ギュ", "ギェ", "ギョ")
kanatbl(25) = Array("ヒャ", "ヒィ", "ヒュ", "ヒュ", "ヒョ")
kanatbl(26) = Array("ジャ", "ジ", "ジュ", "ジェ", "ジョ")
kanatbl(27) = Array("キャ", "キィ", "キュ", "キェ", "キョ")
kanatbl(28) = Array("ャ", "ィ", "ュ", "ェ", "ョ")
kanatbl(29) = Array("ミャ", "ミィ", "ミュ", "ミェ", "ミョ")
kanatbl(30) = Array("ンア", "ンイ", "ンウ", "ンエ", "ンオ")
kanatbl(31) = Array("ニャ", "ニィ", "ニュ", "ニェ", "ニョ")
kanatbl(32) = Array("ピャ", "ピィ", "ピュ", "ピェ", "ピョ")
kanatbl(33) = Array("リャ", "リィ", "リュ", "リェ", "リョ")
kanatbl(34) = Array("シャ", "シ", "シュ", "シェ", "ショ")
kanatbl(35) = Array("シャ", "シィ", "シュ", "シェ", "ショ")
kanatbl(36) = Array("ツァ", "ツィ", "ツ", "ツェ", "ツォ")
kanatbl(37) = Array("チャ", "チィ", "チュ", "チェ", "チョ")
kanatbl(38) = Array("ャ", "ィ", "ュ", "ェ", "ョ")
kanatbl(39) = Array("ジャ", "ジィ", "ジュ", "ジェ", "ジョ")
kanatbl(40) = Array("lta", "lti", "ッ", "lte", "lto")
kanatbl(41) = Array("xta", "xti", "ッ", "xte", "xto")
roma = StrConv(roma, vbNarrow Or vbLowerCase)
retStr = "": Pre = "": i = 1: index = 1
Do While i <= Len(roma)
  k = 0: j1 = 0: j2 = 0
  If Mid(roma, i, 1) Like "[a-z-]" Then
   On Error Resume Next
   k = Application.WorksheetFunction.Match(Mid(roma, i, 1), conv0, 0)
   On Error GoTo 0
   If k > 0 Then
    retStr = retStr & IIf(index = 1, Pre, "") & kanatbl(index)(k - 1)
    Pre = "": i = i + 1: index = 1
   ElseIf k = 0 Then
    On Error Resume Next
    j2 = Application.WorksheetFunction.Match(Mid(roma, i, 2), conv2, 0)
    j1 = Application.WorksheetFunction.Match(Mid(roma, i, 1), conv1, 0)
    On Error GoTo 0
    If j2 > 0 Then j1 = 0
    index = 1 - (j2 > 0) * 19 + j2 + j1
    Select Case Pre
     Case Mid(roma, i, 1)
      retStr = retStr & "ッ"
     Case "n", "nn"
      retStr = retStr & "ン"
     Case "-"
      retStr = retStr & "ー"
     Case Else
      retStr = retStr & Pre
    End Select
    Pre = Mid(roma, i, IIf(j2, 2, 1))
    i = i + 1 + IIf(j2, 1, 0)
   End If
  Else
   retStr = retStr + IIf(Pre = "nn" Or Pre = "n", "ん", Pre) & Mid(roma, i, 1)
   Pre = ""
   index = 1
   i = i + 1
  End If
Loop
roma2kana = retStr & IIf(Pre = "nn" Or Pre = "n", "ん", Pre)
If Not katakana Then roma2kana = StrConv(roma2kana, vbHiragana)
End Function

 

2 Comments

Leave a Reply

Your email address will not be published.


*