分享一段VBA转换汉字为拼音的算法

' 下面的代码由本人逐一核对，实际上也纠正了部分Office本身的错误，

' 如果后续发现更多错误，可以在这个基础上修改增补，也就是说，

' 对EXCEL拼音比较的勘误，后续勘误表可能远大于常规表

'                                       笑十子 2021-03-26

 

' 算法核心：先在特例表中搜索，如果搜索不到，则用常规表

' 根据现在VBA的能力，只能处理2字节Unicode字符，超出该范围的字符无法处理

 

Public Function trzGetPinyinOneHanzi$(hanZi$)

 

    Dim chChr$, pinYinList$()

    Dim regHans$, irrHans$

    Dim regPinYin$, irrPinyin$

   

    Dim nSt&, nEn&, nId&, compRest&, codeVal&

   

    ' 边界值判断

    compRest = StrComp(hanZi, "吖", vbTextCompare)

    If compRest < 0 Then

        trzGetPinyinOneHanzi = hanZi

        Exit Function

    ElseIf compRest = 0 Then

        trzGetPinyinOneHanzi = "A"

        Exit Function

    End If

   

    compRest = StrComp(hanZi, "咗", vbTextCompare)

    If compRest > 0 Then

        trzGetPinyinOneHanzi = hanZi

        Exit Function

    ElseIf compRest = 0 Then

        trzGetPinyinOneHanzi = "Zuo"

        Exit Function

    End If

   

    ' 先在例外项里面查找

    irrHans = "萡琯璭謴蘳駱妎曁仱圧爠唥簗顲囖擽鋢玟銰乜肀堧攴涁挼娞潠咍仐冂崴茠鑰尣"

    irrPinyin = "bo,Guan,Guan,Guan,Hui,Luo,Hai,Ji,Qian,Ya,Qu,Leng,Zhu,Lan,Luo,Luo,Lue,Wen,Ai,Mie," & _

        "Yu,Ruan,Pu,Shen,Ruo,Nei,Xun,Hai,San,Jiong,Wei,Hao,Yue,Wang,"

   

    pinYinList = Split(irrPinyin, ",")

   

    chChr = Left(irrHans, 1)

    compRest = StrComp(hanZi, chChr, vbTextCompare)

    If compRest < 0 Then

        GoTo FindPinyinRegular_todo

    ElseIf compRest = 0 Then

        trzGetPinyinOneHanzi = pinYinList(0)

        Exit Function

    End If

   

    chChr = Right(irrHans, 1)

    compRest = StrComp(hanZi, chChr, vbTextCompare)

    If compRest > 0 Then

        GoTo FindPinyinRegular_todo

    ElseIf compRest = 0 Then

        trzGetPinyinOneHanzi = pinYinList(UBound(pinYinList))

        Exit Function

    End If

   

    nSt = 0

    nEn = UBound(pinYinList)

   

    Do While nSt <= nEn

        nId = (nSt + nEn) / 2

        chChr = mId(irrHans, nId + 1, 1)

        compRest = StrComp(hanZi, chChr, vbTextCompare)

        If compRest = 0 Then

            trzGetPinyinOneHanzi = pinYinList(nId)

            Exit Function

        ElseIf compRest > 0 Then

            nSt = nId + 1

        Else

            nEn = nId - 1

        End If

    Loop

   

    ' 再在常规项里面查找

 

FindPinyinRegular_todo:

    regHans = _

        "吖哎安肮凹八挀扳邦勹杯奔伻皀边标憋汃仌癶逋攃猜参仓撡冊岑噌叉拆觇伥抄车抻阷吃冲抽" & _

        "出欻揣川刅吹杶逴呲匆凑粗汆崔邨搓咑呆丹当刀恴揼灯仾嗲敁刁爹丁丟东吺剢剬垖吨多妸奀" & _

        "鞥儿发帆匚飞分丰覅仏紑夫旮侅甘冈皋戈给根刯工勾估瓜乖关光归衮呙哈还佄夯蒿诃黒拫亨" & _

        "叿齁乎花怀欢巟灰昏吙丌加戋江艽阶巾巠坰丩凥姢撅军咔开刊闶尻苛肎劥空抠扝夸蒯宽匡亏" & _

        "坤扩垃来兰啷捞仂雷塄唎嫾良蹽毟拎伶溜龙瞜撸峦抡啰驴妈埋颟牤猫沒椚擝咪芇喵吀民名谬" & _

        "摸哞母乸腉囡囔孬讷馁嫩能妮拈娘鸟捏脌宁妞农羺奴奻疟黁挪女噢讴帊拍眅乓抛呸喷匉丕囨" & _

        "剽氕拚乒钋剖仆七掐千羌悄切钦青宆丘区奍炔夋冄穣荛惹人扔日戎禸邚阮甤闰叒仨毢三桒掻" & _

        "色森僧杀筛山伤捎奢申升尸収殳刷衰闩双谁吮说厶忪凁苏狻夊孙莏他囼坍汤弢忑膯剔天旫帖" & _

        "厅囲偷凸猯推吞乇屲咼弯尪危昷翁挝乌夕虾仙乡灲些心兴凶休戌吅削坃丫咽央幺耶一囙応哟" & _

        "佣优込囦曰晕帀灾兂赃遭则贼怎囎扎捚枬弡钊蜇贞黮之中舟朱抓跩专妆隹迍拙孖宗邹租劗厜" & _

        "尊嘬"

   

    regPinYin = "A,Ai,An,Ang,Ao,Ba,Bai,Ban,Bang,Bao,Bei,Ben,Beng,Bi,Bian,Biao,Bie,Bin,Bing,Bo," & _

        "Bu,Ca,Cai,Can,Cang,Cao,Ce,Cen,Ceng,Cha,Chai,Chan,Chang,Chao,Che,Chen,Cheng,Chi,Chong,Chou," & _

        "Chu,Chua,Chuai,Chuan,Chuang,Chui,Chun,Chuo,Ci,Cong,Cou,Cu,Cuan,Cui,Cun,Cuo,Da,Dai,Dan,Dang," & _

        "Dao,De,Den,Deng,Di,Dia,Dian,Diao,Die,Ding,Diu,Dong,Dou,Du,Duan,Dui,Dun,Duo,E,En," & _

        "Eng,Er,Fa,Fan,Fang,Fei,Fen,Feng,Fiao,Fo,Fou,Fu,Ga,Gai,Gan,Gang,Gao,Ge,Gei,Gen," & _

        "Geng,Gong,Gou,Gu,Gua,Guai,Guan,Guang,Gui,Gun,Guo,Ha,Hai,Han,Hang,Hao,He,Hei,Hen,Heng," & _

        "Hong,Hou,Hu,Hua,Huai,Huan,Huang,Hui,Hun,Huo,Ji,Jia,Jian,Jiang,Jiao,Jie,Jin,Jing,Jiong,Jiu," & _

        "Ju,Juan,Jue,Jun,Ka,Kai,Kan,Kang,Kao,Ke,Ken,Keng,Kong,Kou,Ku,Kua,Kuai,Kuan,Kuang,Kui," & _

        "Kun,Kuo,La,Lai,Lan,Lang,Lao,Le,Lei,Leng,Li,Lian,Liang,Liao,Lie,Lin,Ling,Liu,Long,Lou," & _

        "Lu,Luan,Lun,Luo,Lv,Ma,Mai,Man,Mang,Mao,Mei,Men,Meng,Mi,Mian,Miao,Mie,Min,Ming,Miu," & _

        "Mo,Mou,Mu,Na,Nai,Nan,Nang,Nao,Ne,Nei,Nen,Neng,Ni,Nian,Niang,Niao,Nie,Nin,Ning,Niu," & _

        "Nong,Nou,Nu,Nuan,Nue,Nun,Nuo,Nv,O,Ou,Pa,Pai,Pan,Pang,Pao,Pei,Pen,Peng,Pi,Pian," & _

        "Piao,Pie,Pin,Ping,Po,Pou,Pu,Qi,Qia,Qian,Qiang,Qiao,Qie,Qin,Qing,Qiong,Qiu,Qu,Quan,Que," & _

        "Qun,Ran,Rang,Rao,Re,Ren,Reng,Ri,Rong,Rou,Ru,Ruan,Rui,Run,Ruo,Sa,Sai,San,Sang,Sao," & _

        "Se,Sen,Seng,Sha,Shai,Shan,Shang,Shao,She,Shen,Sheng,Shi,Shou,Shu,Shua,Shuai,Shuan,Shuang,Shui,Shun," & _

        "Shuo,Si,Song,Sou,Su,Suan,Sui,Sun,Suo,Ta,Tai,Tan,Tang,Tao,Te,Teng,Ti,Tian,Tiao,Tie," & _

        "Ting,Tong,Tou,Tu,Tuan,Tui,Tun,Tuo,Wa,Wai,Wan,Wang,Wei,Wen,Weng,Wo,Wu,Xi,Xia,Xian," & _

        "Xiang,Xiao,Xie,Xin,Xing,Xiong,Xiu,Xu,Xuan,Xue,Xun,Ya,Yan,Yang,Yao,Ye,Yi,Yin,Ying,Yo," & _

        "Yong,You,Yu,Yuan,Yue,Yun,Za,Zai,Zan,Zang,Zao,Ze,Zei,Zen,Zeng,Zha,Zhai,Zhan,Zhang,Zhao," & _

        "Zhe,Zhen,Zheng,Zhi,Zhong,Zhou,Zhu,Zhua,Zhuai,Zhuan,Zhuang,Zhui,Zhun,Zhuo,Zi,Zong,Zou,Zu,Zuan,Zui,Zun,Zuo"

 

    pinYinList = Split(regPinYin, ",")

 

    nSt = 0

    nEn = UBound(pinYinList)

    Do While nSt <= nEn

        nId = (nSt + nEn) / 2

        chChr = mId(regHans, nId + 1, 1)

        compRest = StrComp(hanZi, chChr, vbTextCompare)

        If compRest = 0 Then

            Exit Do

        ElseIf compRest > 0 Then

            nSt = nId + 1

        Else

            nEn = nId - 1

        End If

    Loop

   

    If compRest < 0 Then nId = nId - 1

 

    trzGetPinyinOneHanzi = pinYinList(nId)

 

End Function

 

' 获得中文名字符数（便于拼接：比如

'       欧阳娜娜，  Ouyang Nana

'       宋小宝，    Song Xiaobao

'       宋江        Song Jiang

Private Function getChsNameLen&(chsName$, ByVal stLoc&)

   

    Dim chC$

    Dim nC&, uniCodeVal&, chsQ&

   

    chsQ = 0

    For nC = stLoc To Len(chsName)

        chC = mId(chsName, nC, 1)

        uniCodeVal = AscW(chC)

        If uniCodeVal < 0 Then uniCodeVal = uniCodeVal + 65536

       

        If chC = " " Or chC = Chr(10) Then

            ' 空格，跳过

        ElseIf uniCodeVal < 19968 Or uniCodeVal > 40956 Then

            ' 不是汉字，退出

            Exit For

        Else

            chsQ = chsQ + 1

        End If

    Next nC

 

    getChsNameLen = chsQ

 

End Function

 

' 将汉字姓名转换为拼音姓名

Public Function getPinYinName$(chsName$)

   

    Dim nC&, nSt&, nEn&

    Dim uniCodeVal&, chsNameLen&, chsNameCnt&

    Dim retStr$, chC$, nameStr$

   

    retStr = "":        nameStr = ""

    For nC = 1 To Len(chsName)

       

        chC = mId(chsName, nC, 1)

        uniCodeVal = AscW(chC)

        If uniCodeVal < 0 Then uniCodeVal = uniCodeVal + 65536

       

        If uniCodeVal < 19968 Or uniCodeVal > 40956 Then

            If nameStr <> "" Then

                nameStr = Application.WorksheetFunction.Proper(nameStr)

                If retStr <> "" Then retStr = retStr & " "

                retStr = retStr & nameStr & " "

                nameStr = ""

            End If

            retStr = retStr & chC

       

        Else

            If nameStr = "" Then

                chsNameLen = getChsNameLen(chsName, nC)

                chsNameCnt = 0

            End If

           

            If chsNameCnt = 0 Then

                nameStr = trzGetPinyinOneHanzi(chC)

            ElseIf (chsNameLen <= 3 And chsNameCnt = 1) Or _

                (chsNameLen >= 4 And chsNameCnt = 2) Then

                nameStr = nameStr & " " & trzGetPinyinOneHanzi(chC)

            Else

                nameStr = nameStr & trzGetPinyinOneHanzi(chC)

            End If

            chsNameCnt = chsNameCnt + 1

        End If

   

    Next nC

   

    If nameStr <> "" Then

        nameStr = Application.WorksheetFunction.Proper(nameStr)

        retStr = retStr & nameStr

    End If

   

    getPinYinName = retStr

 

End Function

 

' 将汉字转换为拼音首字母

Public Function getAbbrPinYin(chsName As String) As String

   

    Dim nC As Long, nSt As Long, nEn As Long

    Dim uniCodeVal As Long, chsNameLen As Long, chsNameCnt As Long

    Dim retStr As String, chC As String, fstChr As String, nameStr As String

   

    retStr = "":        nameStr = ""

    For nC = 1 To Len(chsName)

       

        chC = mId(chsName, nC, 1)

        uniCodeVal = AscW(chC)

        If uniCodeVal < 0 Then uniCodeVal = uniCodeVal + 65536

       

        If uniCodeVal < 19968 Or uniCodeVal > 40956 Then

            If nameStr <> "" Then

                nameStr = Application.WorksheetFunction.Proper(nameStr)

                If retStr <> "" Then retStr = retStr & " "

                retStr = retStr & nameStr & " "

                nameStr = ""

            End If

            retStr = retStr & chC

       

        Else

            If nameStr = "" Then

                chsNameLen = getChsNameLen(chsName, nC)

                chsNameCnt = 0

            End If

           

            nameStr = nameStr & Left(trzGetPinyinOneHanzi(chC), 1)

            chsNameCnt = chsNameCnt + 1

        End If

   

    Next nC

   

    If nameStr <> "" Then

        nameStr = Application.WorksheetFunction.Proper(nameStr)

        retStr = retStr & nameStr

    End If

   

    getAbbrPinYin = retStr

 

End Function