[[20111021184803]]　『カタカナをアルファベット小文字に変換』（miyafire）　ページの最後に飛ぶ

『カタカナをアルファベット小文字に変換』（miyafire）Excel2003 WindowsXP

カタカナをアルファベット小文字に変換するマクロです。

ネット上にあったものを改変して作ったので、マクロについて詳しくはないです。

小文字ュ等（ひとつの単語で2回目以降）と末尾のッが変換されません。

変換できるように改変して貰えると助かります。

Public Const Roma_Boin = "aiueo"

Public Const Kata_S1 = "aアイウエオkカキクケコsサシスセソtタチツテトnナニヌネノ"

Public Const Kata_S2 = "hハヒフヘホmマミムメモyヤイユエヨrラリルレロwワイウエヲ"

Public Const Kata_S3 = "gガギグゲゴzザジズゼゾdダヂヅデドbバビブベボpパピプペポv☆☆ヴ☆☆"

Public Function changeKatakana2Romaji(srcMoji As String)
　　

    Dim kataMoji As String 'カタカナ文字

　　Dim RomaMoji As String 'ローマ字

　　Dim L As Long '文字カウンタ

　　Dim elm As String '1文字

　　Dim Pot As Integer '変換テーブルでの位置

　　Dim wkBoin, wkSiin As String '母音と子音

　　Dim chgTBL As String '変換テーブル

　　　　chgTBL = Kata_S1 & Kata_S2 & Kata_S3

　　kataMoji = StrConv(srcMoji, vbKatakana + vbWide) '全角カタカナにして『゛゜』を処理

　　Application.Volatile

　　For L = 1 To Len(kataMoji) 'カタカナ全角文字の母音と子音を作る

　　　　elm = Mid(kataMoji, L, 1): Pot = InStr(chgTBL, elm)

　　　　If 0 < Pot And Pot <= 6 Then

　　　　　　wkBoin = Mid(Roma_Boin, Pot - 1, 1): wkSiin = "": elm = wkBoin & wkSiin

　　　　ElseIf Pot > 6 Then

　　　　　　wkBoin = Mid(chgTBL, Int((Pot - 1) / 6) * 6 + 1, 1)

　　　　　　wkSiin = Mid(Roma_Boin, (Pot - 1) Mod 6, 1): elm = wkBoin & wkSiin

　　　　Else

　　　　　　If elm = "ン" Then elm = "n" '『ン』は特別処理

　　　　End If

　　　　RomaMoji = RomaMoji & elm

　　RomaMoji = KomojiOkikae(RomaMoji, "ャ", "ya") '小文字『ャ』の処理

　　RomaMoji = KomojiOkikae(RomaMoji, "ュ", "yu") '小文字『ュ』の処理

　　RomaMoji = KomojiOkikae(RomaMoji, "ョ", "yo") '小文字『ョ』の処理

　　RomaMoji = KomojiOkikae(RomaMoji, "ァ", "xa") '小文字『ァ』の処理

　　RomaMoji = KomojiOkikae(RomaMoji, "ィ", "xi") '小文字『ィ』の処理

　　RomaMoji = KomojiOkikae(RomaMoji, "ゥ", "xu") '小文字『ゥ』の処理

　　RomaMoji = KomojiOkikae(RomaMoji, "ェ", "xe") '小文字『ェ』の処理

　　RomaMoji = KomojiOkikae(RomaMoji, "ォ", "xo") '小文字『ォ』の処理

　　For L = 2 To Len(RomaMoji) '小文字『ッ』の処理

　　　　If Mid(RomaMoji, L - 1, 1) = "ッ" Then

　　　　　　Mid(RomaMoji, L - 1, 1) = Mid(RomaMoji, L, 1)

　　　　End If

　　changeKatakana2Romaji = StrConv(RomaMoji, vbNarrow)

End Function

'カタカナ小文字の処理（ャュョァィゥェォ）

Public Function KomojiOkikae(Moji As String, komoji As String, Okikae As String)

　　Dim kPot As Integer

　　If InStr(Moji, komoji) > 0 Then

　　　　Mid(Moji, InStr(Moji, komoji) - 1, 2) = Okikae

　　End If

　　KomojiOkikae = Moji

End Function

 １．カタカナ小文字の処理は、
 　　こんな風にすれば、複数に対応出来ると思います。
       ↓
 'カタカナ小文字の処理（ャュョァィゥェォ）

 Public Function KomojiOkikae(Moji As String, komoji As String, Okikae As String)

     Dim kPot As Integer

     Do While InStr(Moji, komoji) > 0
         Mid(Moji, InStr(Moji, komoji) - 1, 2) = Okikae
     Loop

     KomojiOkikae = Moji

 End Function

 ＞末尾のッが変換されません。 
 ２．それってローマ字に出来るのですか？
 　　実例を挙げていただけませんか？　(カタカナとローマ字)

 (半平太) 2011/10/23 21:42

1.ありがとうございます。対応できました。

2.マンガ等本のタイトルを変換するので、末尾が
ナリタイッ/スルナヨッ
というデータがあるのです。
小文字のッはxtuで変換されるので、末尾の時のみそちらで対応して頂ければ助かります。

(miyafire)

 個人的には、記号の「!」にした方がニュアンスは近いと思いますが・・・・

 以下、"xtu" に変える案（最下行近くに3行追加してあります)

 Public Function changeKatakana2Romaji(srcMoji As String)

    Dim kataMoji As String 'カタカナ文字
    Dim RomaMoji As String 'ローマ字
    Dim L As Long '文字カウンタ
    Dim elm As String '1文字
    Dim Pot As Integer '変換テーブルでの位置
    Dim wkBoin, wkSiin As String '母音と子音
    Dim chgTBL As String '変換テーブル

        chgTBL = Kata_S1 & Kata_S2 & Kata_S3

    kataMoji = StrConv(srcMoji, vbKatakana + vbWide) '全角カタカナにして『゛゜』を処理

    Application.Volatile

    For L = 1 To Len(kataMoji) 'カタカナ全角文字の母音と子音を作る

        elm = Mid(kataMoji, L, 1): Pot = InStr(chgTBL, elm)

        If 0 < Pot And Pot <= 6 Then
            wkBoin = Mid(Roma_Boin, Pot - 1, 1): wkSiin = "": elm = wkBoin & wkSiin
        ElseIf Pot > 6 Then
            wkBoin = Mid(chgTBL, Int((Pot - 1) / 6) * 6 + 1, 1)
            wkSiin = Mid(Roma_Boin, (Pot - 1) Mod 6, 1): elm = wkBoin & wkSiin
        Else
            If elm = "ン" Then elm = "n" '『ン』は特別処理
        End If

        RomaMoji = RomaMoji & elm
    Next

    RomaMoji = KomojiOkikae(RomaMoji, "ャ", "ya") '小文字『ャ』の処理
    RomaMoji = KomojiOkikae(RomaMoji, "ュ", "yu") '小文字『ュ』の処理
    RomaMoji = KomojiOkikae(RomaMoji, "ョ", "yo") '小文字『ョ』の処理
    RomaMoji = KomojiOkikae(RomaMoji, "ァ", "xa") '小文字『ァ』の処理
    RomaMoji = KomojiOkikae(RomaMoji, "ィ", "xi") '小文字『ィ』の処理
    RomaMoji = KomojiOkikae(RomaMoji, "ゥ", "xu") '小文字『ゥ』の処理
    RomaMoji = KomojiOkikae(RomaMoji, "ェ", "xe") '小文字『ェ』の処理
    RomaMoji = KomojiOkikae(RomaMoji, "ォ", "xo") '小文字『ォ』の処理

    For L = 2 To Len(RomaMoji) '小文字『ッ』の処理
        If Mid(RomaMoji, L - 1, 1) = "ッ" Then
            Mid(RomaMoji, L - 1, 1) = Mid(RomaMoji, L, 1)
        End If
    Next

    If Right(RomaMoji, 1) = "ッ" Then                              'この3行を追加
        RomaMoji = Replace(RomaMoji, "ッ", "xtu")                  'この3行を追加
    End If                                                         'この3行を追加

    changeKatakana2Romaji = StrConv(RomaMoji, vbNarrow)

 End Function

 (半平太) 2011/10/24 11:33

 いまさらですが一様作ってみましたのでアップしときます。
無駄コードが有ると思いますが、カタカナ部分のみローマ字変換その他はそのままになる予定（beginner） 
ナリタイッ/スルナヨッ　　　naritaixtu/surunayoxtu
ｼﾞｮギャット8ﾟﾞ８９0ﾟﾋﾞｭﾞ7ﾞ　jogyatto8ﾟﾞ８９0ﾟbyuﾞ7ﾞ

 Function kana(txta As String)
    Dim myStr As String, myData(2)
    Dim i As Long, ii As Long, c As Long, daku As Long, i2 As Long
    Dim txt As String, txtx As String, sl As Long, dic As Object, dic2
    myData(0) = "ア,イ,ウ,エ,オ,ァ,ィ,ゥ,ェ,ォ,カ,キ,ク,ケ,コ,サ,シ,ス,セ,ソ,タ,チ,ツ,テ,ト,ナ,ニ,ヌ" & _
             ",ネ,ノ,ハ,ヒ,フ,ヘ,ホ,マ,ミ,ム,メ,モ,ヤ,ユ,ヨ,ラ,リ,ル,レ,ロ,ガ,ギ,グ,ゲ,ゴ,ヴ,ザ" & _
            ",ジ,ズ,ゼ,ゾ,ダ,ヂ,ヅ,デ,ド,バ,ビ,ブ,ベ,ボ,パ,ピ,プ,ペ,ポ,ャ,ュ,ョ,ワ,ヲ,ッ,ン" & _
            ",イェ,ウィ,ウェ,ヴァ,ヴィ,ヴェ,ヴォ,ジャ,ジュ,ジェ,ジョ,ファ,フィ,フェ,フォ,キャ,キィ,キュ,キェ,キョ" & _
            ",シャ,シィ,シュ,シェ,ショ,チャ,チィ,チュ,チェ,チョ,ニャ,ニィ,ニュ,ニェ,ニョ,ヒャ,ヒィ,ヒュ" & _
            ",ヒェ,ヒョ,フャ,フュ,フョ,ミャ,ミィ,ミュ,ミェ,ミョ,リャ,リィ,リュ,リェ,リョ,ギャ,ギィ,ギュ" & _
            ",ギェ,ギョ,ジィ,ヂャ,ヂィ,ヂュ,ヂェ,ヂョ,ビャ,ビィ,ビュ,ビェ,ビョ,ピャ,ピィ,ピュ,ピェ,ピョ" & _
            ",テャ,ティ,テュ,テェ,テョ,デャ,ディ,デュ,デェ,デョ,ツァ,ツィ,ツェ,ツォ"

    myData(1) = StrConv("Ａ,Ｉ,Ｕ,Ｅ,Ｏ,ＸＡ,ＸＩ,ＸＵ,ＸＥ,ＸＯ,ＫＡ,ＫＩ,ＫＵ,ＫＥ,ＫＯ,ＳＡ,ＳＩ,ＳＵ,ＳＥ,ＳＯ,ＴＡ,ＴＩ,ＴＵ,ＴＥ,ＴＯ,ＮＡ,ＮＩ,ＮＵ" & _
            ",ＮＥ,ＮＯ,ＨＡ,ＨＩ,ＨＵ,ＨＥ,ＨＯ,ＭＡ,ＭＩ,ＭＵ,ＭＥ,ＭＯ,ＹＡ,ＹＵ,ＹＯ,ＲＡ,ＲＩ,ＲＵ,ＲＥ,ＲＯ,ＧＡ,ＧＩ,ＧＵ,ＧＥ,ＧＯ,ＶＵ,ＺＡ" & _
            ",ＺＩ,ＺＵ,ＺＥ,ＺＯ,ＤＡ,ＤＩ,ＤＵ,ＤＥ,ＤＯ,ＢＡ,ＢＩ,ＢＵ,ＢＥ,ＢＯ,ＰＡ,ＰＩ,ＰＵ,ＰＥ,ＰＯ,ＸＹＡ,ＸＹＵ,ＸＹＯ,ＷＡ,ＷＯ,ＸＴＵ,ＮＮ" & _
            ",ＹＥ,ＷＩ,ＷＥ,ＶＡ,ＶＩ,ＶＥ,ＶＯ,ＪＡ,ＪＵ,ＪＥ,ＪＯ,ＦＡ,ＦＩ,ＦＥ,ＦＯ,ＫＹＡ,ＫＹＩ,ＫＹＵ,ＫＹＥ,ＫＹＯ" & _
            ",ＳＹＡ,ＳＹＩ,ＳＹＵ,ＳＹＥ,ＳＹＯ,ＴＹＡ,ＴＹＩ,ＴＹＵ,ＴＹＥ,ＴＹＯ,ＮＹＡ,ＮＹＩ,ＮＹＵ,ＮＹＥ,ＮＹＯ,ＨＹＡ,ＨＹＩ,ＨＹＵ" & _
            ",ＨＹＥ,ＨＹＯ,ＦＹＡ,ＦＹＥ,ＦＹＯ,ＭＹＡ,ＭＹＩ,ＭＹＵ,ＭＹＥ,ＭＹＯ,ＲＹＡ,ＲＹＩ,ＲＹＵ,ＲＹＥ,ＲＹＯ,ＧＹＡ,ＧＹＩ,ＧＹＵ" & _
            ",ＧＹＥ,ＧＹＯ,ＺＹＩ,ＤＹＡ,ＤＹＩ,ＤＹＵ,ＤＹＥ,ＤＹＯ,ＢＹＡ,ＢＹＩ,ＢＹＵ,ＢＹＥ,ＢＹＯ,ＰＹＡ,ＰＹＩ,ＰＹＵ,ＰＹＥ,ＰＹＯ" & _
            ",ＴＨＡ,ＴＨＩ,ＴＨＵ,ＴＨＥ,ＴＨＯ,ＤＨＡ,ＤＨＩ,ＤＨＵ,ＤＨＥ,ＤＨＯ,ＴＳＡ,ＴＳＩ,ＴＳＥ,ＴＳＯ", 3 + 8) 'StrConv　文字種類を変換
    myData(2) = "ガ,ギ,グ,ゲ,ゴ,ザ,ジ,ズ,ゼ,ゾ,ダ,ヂ,ヅ,デ,ド,バ,ビ,ブ,ベ,ボ,パ,ピ,プ,ペ,ポ"
    For ii = 0 To 2
        myData(ii) = Split(myData(ii), ",")
    Next ii
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")

    For i = 0 To UBound(myData(0))
        dic.Add myData(0)(i), myData(1)(i)  'myData(0)＆myData(1) を格納　（StrConv(myData(1)(i), 3）で単語先頭文字を大文字）
    Next i

    For i2 = 0 To UBound(myData(2))
        dic2.Add myData(2)(i2), ""            'myData(2)＆"" を格納
    Next i2

    txt = txta                              '基準の値を一時保管（大角・小角はそのままで、カタカナ以外を値を変換させない）
    txta = StrConv(txt, 4)                  '(仮）として、大角に変換

    For sl = 1 To Len(txta)
        If dic.Exists(Mid(txta, sl, 2)) Then            '(仮）2文字が変数に一致？ﾟ
            txtx = txtx & dic(Mid(txta, sl, 2))         '値にアルファベット2文字分格納
            If Mid(txt, sl + daku, 2) Like "?[ﾞ]" Or Mid(txt, sl + daku, 2) Like "？[ﾟ]" Then daku = daku + 1 'さらに、基準値の2文字分が（ﾟﾞ）の判断
            sl = sl + 1
        ElseIf Mid(txta, sl, 2) Like "[ッ][ア-ン]" Then '(仮）が、ッから始まり次の文字がカタカナ？
            If dic.Exists(Mid(txta, sl + 1, 2)) Then    '(仮）が、ッの次2文字が変数に一致？
                txtx = txtx & Left(dic(Mid(txta, sl + 1, 2)), 1) & dic(Mid(txta, sl + 1, 2)) 'ッの次2文字のアルファベット1文字＆変数
                If Not dic2.Exists(Mid(txt, sl + daku + 2, 1)) And dic2.Exists(Mid(txta, sl + 1, 1)) Then daku = daku + 1   '基準の値が半角濁点の場合
                If dic2.Exists(Mid(txt, sl + daku, 1)) Then daku = daku - 1
                sl = sl + 2
            Else
                txtx = txtx & Left(dic(Mid(txta, sl + 1, 1)), 1) & dic(Mid(txta, sl + 1, 1)) 'ッの次1文字のアルファベット1文字＆変数
               If (Mid(txt, sl + daku, 3) Like "？[ﾞ]" Or Mid(txt, sl + daku, 3) Like "？[ﾟ]") And dic2.Exists(Mid(txta, sl + 1, 1)) Then daku = daku + 1
               If dic2.Exists(Mid(txta, sl + 1, 1)) And Not dic2.Exists(Mid(txt, sl + daku + 1, 1)) Then daku = daku + 1
                sl = sl + 1
            End If
        ElseIf dic.Exists(Mid(txta, sl, 1)) Then
            txtx = txtx & dic(Mid(txta, sl, 1))
            If (Mid(txt, sl + daku, 2) Like "?[ﾞ]" Or Mid(txt, sl + daku, 2) Like "?[ﾟ]") And dic2.Exists(Mid(txta, sl, 1)) And Not dic2.Exists(Mid(txt, sl, 1)) Then
'                                                                                             dic2に　存在する場合
                daku = daku + 1
            End If
        Else
            txtx = txtx & Mid(txt, sl + daku, 1)
        End If
    Next
    kana = txtx '戻し値
    Set dic = Nothing
    Set dic2 = Nothing
End Function

コメント返信：

[ 一覧(最新更新順) ]

[[20111021184803]] 『カタカナをアルファベット小文字に変換』（miyafire） ページの最後に飛ぶ

[[20111021184803]]　『カタカナをアルファベット小文字に変換』（miyafire）　ページの最後に飛ぶ