半角片假名转换成全角平假名

amtf995

一直在论坛中潜水，获益菲浅，最近想操作日文半角片假名，发现在VBA中显示 为？号。想了一个办法，把日文半角片角名的Unicode内码与全角片角名对应做一个表，把半角片假名转换为全角片角名。代码可能非常丑陋，请大家不吝指教！

详情看附件。
贴一部分对照表，全部贴出超出帖子限制。

片假名半角	半角片假名Unicode				片假名全角	全角码表		平假名	平假名Unicode
ｦ	102	255			ヲ	172	48	ぁ	65	48
ｧ	103	255			ァ	174	48	あ	66	48
ｨ	104	255			ィ	176	48	ぃ	67	48
ｩ	105	255			ゥ	178	48	い	68	48

代码：

Public Function BConvQ(sName As String)
'半角片假名转换为全角片假函数
'问题：半角片假名使用VBA处理时只显示“？”。
'解决办法：把半角片假名转换成unicode码，并使用“日文码表”查找对应的全角片假名，使用全角片假名显示。
'难点：半角片假名的长度有的是1，有的是2。对应的Unicode码有2组的，有4组的。
Dim CodeSheet
Dim x() As Byte
Dim Sh As Worksheet
Dim S As String

Set Sh = Sheets("日文码表")

CodeSheet = Sh.Range("B2:F83") '转换码表赋值给数组

S = ""

l = Len(sName)  '获取字符串长度

For i = 1 To l
    If l - i >= 2 Then  '如果不是字符串最后一个字符，则取两个字符进行操作
        c = Mid(sName, i, 2)    '从字符串sName的第i个位置取2个字符
        x = c                   '把获取的2个字符串赋值给数组
        If (x(2) = 158 And x(3) = 255) Or (x(2) = 159 And x(3) = 255) Then     '判断是否为双字节片假名
            For j = 1 To UBound(CodeSheet, 1)
                If x(0) = CodeSheet(j, 1) And x(2) = CodeSheet(j, 3) Then
                    S = S + CodeSheet(j, 5) '用双字节全角片假名替换双字节半角片假名
                    i = i + 1               '如果是双字节，则循环次数减1，即i+1
                    Exit For
                End If
            Next j
        Else                                '为单字节字符
            If x(1) = 255 Then      '判断第一个字节是否为半角片假名【片假名Unicode码的第二位为255】
                For k = 1 To UBound(CodeSheet, 1)
                    If x(0) = CodeSheet(k, 1) Then
                            S = S + CodeSheet(k, 5)     '第一个字符是半角片假名，则用全角半假名替换半角片假名
                            Exit For
                    End If
                Next k
'            ElseIf x(1) = 48 Then   '判断是否平假名【平假名和全角片假名Unicode码的第二位为48】  这一判断多余了。
'                S = S + Left(c, 1)         '第一个字符不是半角片假名，则取字符串的第一个字符
            Else
                 S = S + Left(c, 1)         '第一个字符不是半角片假名，则取字符串的第一个字符
            End If
        End If
    Else     '是字符串最后一个字符
        c = Mid(sName, i, 1)
        x = c
        If x(1) = 255 Then      '判断第一个字节是否为半角片假名【片假名Unicode码的第二位为255】
            For k = 1 To UBound(CodeSheet, 1)
                If x(0) = CodeSheet(k, 1) Then
                        S = S + CodeSheet(k, 5)
                        Exit For
                End If
            Next k
        Else
            S = S + c
        End If
    End If
    Erase x
Next i

BConvQ = S

End Function


Sub 半角片假名转换成全角平假名()
Dim sName As String
sName = Sheets("日文码表").Range("M2").Value
Sheets("日文码表").Range("M3") = BConvQ(sName)
End Sub

snake4916862

谢谢你提供的方法与code
已应用到自己的项目中
谢谢！

qianwei432

谢谢楼主，辛苦了