为EXCEL中的姓名添加拼音首字母。。。
EXCEL首字母返回函数
(在"工具"菜单上，指向"宏"，然后单击"Visual Basic 编辑器"。
在"Microsoft Visual Basic"窗口中的"插入"菜单上，单击"模块"。
) 可以在EXCEL->插入->函数->用户定义中可以到此函数(HYPY)与其它函数一样使用
Function HYPY(myStr As String) As String
Dim L As Integer, i As Integer
Dim GetPY As String, N As String
On Error Resume Next
myStr = StrConv(myStr, vbNarrow)
L = Len(myStr)
For i = 1 To L
If Asc(Mid(myStr, i, 1)) > 0 Or Err.Number = 1004 Then N = ""
N = Application.WorksheetFunction.VLookup(Mid(myStr, i, 1), _
[{"吖","A";"八","B";"嚓","C";"咑","D";"鵽","E";"发","F";"猤","G";"铪","H";"夻","J";"咔","K";"垃","L";"呒","M";"旀","N";"噢","O";"妑","P";"七","Q";"囕","R";"仨","S";"他","T";"屲","W";"夕","X";"丫","Y";"帀","Z"}], 2)
GetPY = GetPY & N
Next i
HYPY = GetPY
End Function
================================================
如何提取汉语拼音的首字？一般来说，有两种方法！
  ①函数法：利用vlookup，但有一定的局限性，效率也是问题。
  ②vba法：是最佳的选择，并且，仅使用几行Excel VBA代码就行，为什么这么说呢？因为Excel里利用Vlookup工作表函数和eva luate方法可以快捷的计算出结果。
  通过如下例子可以看出Excel VBA独有的优势。代码如下
  Public Function MyPY(ByVal vText As Variant) As String
  Application.Volatile
  Dim strResult As String
  Dim lStart As Long
  On Error Resume Next
  For lStart = 1 To Len(vText)
  strResult = strResult & Application.eva luate("VLookup(""" & Mid(vText, _
lStart, 1) & _
""",  {""吖"",""A"";""八"",""B"";""嚓"",""C"";""咑"",""D"";""鵽"",""E"";""发"",""F"";""猤"",""G"";& _
""铪"",""H"";""夻"",""J"";""咔"",""K"";""垃"",""L"";""嘸"",""M"";""旀"",""N"";""噢"",""O"";&_
""妑"",""P"";""七"",""Q"";""囕"",""R"";""仨"",""S"";""他"",""T"";""屲"",""W"";""夕"",""X"";& _"
"丫"",""Y"";""帀"",""Z""},2,1)")
Next
  MyPY = strResult
  End Function
  上文自定义函数提取的是纯汉字，但“中华人民共和国123（辽宁）”要求返回“ZHRMGHG（LN）”
“中华人民共和国1-辽宁”返回“ZHRMGHG-LN”怎么办？
  关键点：
  ①排除A~Z a~z 0~9，就是所有字母和数字。
  ②判断是否为每个提取的字符是否汉字。一般判断为汉字可以利用ASC码值判断，这里我提供另一种方法。
  整体代码如下：
  Public Function SuperPY(ByVal vText As Variant) As String
  Application.Volatile
  Dim strResult As String
  Dim lStart As Long
  Dim sTemp As String
  On Error Resume Next
  For lStart = 1 To Len(vText)
  sTemp = VBA.StrConv(Mid(vText, lStart, 1), vbNarrow)
If sTemp Like "[!A-Z !a-z !0-9]" Then '排除什么可以
在like表达式中修改
If Len(sTemp) <> LenB(StrConv(sTemp, vbFromUnicode)) Then
strResult = strResult & Application.eva luate("VLookup(""" & Mid(vText, _
lStart, 1) & _
""",{""吖"",""A"";""八"",""B"";""嚓"",""C"";""咑"",""D"";""鵽"",""E"";""发"",""F"";""猤"",""G"";& _
""铪"",""H"";""夻"",""J"";""咔"",""K"";""垃"",""L"";""嘸"",""M"";""旀"",""N"";""噢"",""O"";""妑"",& _
""P"";""七"",""Q"";""囕"",""R"";""仨"",""S"";""他"",""T"";""屲"",""W"";""夕"",""X"";""丫"",""Y"";""帀"",""Z""},2,1)")
Else
strResult = strResult & Mid(vText, lStart, 1)
End If
End If
  Next
  SuperPY = strResult
  End Function
===================================================
excel汉字取首字母
打开Excel->工具->宏->Viaual Basic编辑器
在弹出来的窗口中对着VBAproject点右键->插入->模块
下面会出现一个名为"模块1"，点击
在右边的空白栏中粘贴以下内容：
Function getpychar(char)
tmp = 65536 + Asc(char)
If (tmp >= 45217 And tmp <= 45252) Then
getpychar = "A"
ElseIf (tmp >= 45253 And tmp <= 45760) Then
getpychar = "B"
ElseIf (tmp >= 45761 And tmp <= 46317) Then
getpychar = "C"
ElseIf (tmp >= 46318 And tmp <= 46825) Then
getpychar = "D"
ElseIf (tmp >= 46826 And tmp <= 47009) Then
getpychar = "E"
ElseIf (tmp >= 47010 And tmp <= 47296) Then
getpychar = "F"
ElseIf (tmp >= 47297 And tmp <= 47613) Then
getpychar = "G"
ElseIf (tmp >= 47614 And tmp <= 48118) Then
getpychar = "H"
ElseIf (tmp >= 48119 And tmp <= 49061) Then
getpychar = "J"
ElseIf (tmp >= 49062 And tmp <= 49323) Then
getpychar = "K"
ElseIf (tmp >= 49324 And tmp <= 49895) Then
getpychar = "L"
ElseIf (tmp >= 49896 And tmp <= 50370) Then
getpychar = "M"
ElseIf (tmp >= 50371 And tmp <= 50613) Then
getpychar = "N"
ElseIf (tmp >= 50614 And tmp <= 50621) Then
getpychar = "O"
ElseIf (tmp >= 50622 And tmp <= 50905) Then
getpychar = "P"
ElseIf (tmp >= 50906 And tmp <= 51386) Then
getpychar = "Q"
ElseIf (tmp >= 51387 And tmp <= 51445) Then
getpychar = "R"
ElseIf (tmp >= 51446 And tmp <= 52217) Then
getpychar = "S"
ElseIf (tmp >= 52218 And tmp <= 52697) Then
getpychar = "T"
ElseIf (tmp >= 52698 And tmp <= 52979) Then
getpychar = "W"
ElseIf (tmp >= 52980 And tmp <= 53640) Then
getpychar = "X"
ElseIf (tmp >= 53689 And tmp <= 54480) Then
getpychar = "Y"
ElseIf (tmp >= 54481 And tmp <= 62289) Then
getpychar = "Z"
Else '如果不是中文，则不处理
getpychar = char
End If
End Function
Function getpy(str)
For i = 1 To Len(str)
getpy = getpy & getpychar(Mid(str, i, 1))
Next i
End Function
********复制到此结束，本行不复制*******
现在转换函数已编写完成!关掉此编缉的窗口。
要在Excel中使用，方法如下：
A1 A2
中国 =getpy(A1)
】
====================================
一个自定义函数，可提取中文字串中每个字符的拼音首字母，忽略字串中的英文字母和标点，阿拉伯数字，空格等。
附件
中有使用范例。
已发现的缺点：不能识别多音字，比如 “单”有"shan、dan"两种读音，其只能识别一种；
到底能识别多少中文字，我也不清楚。
Function HYPY(myStr As String) As String
Dim L As Integer, i As Integer
Dim GetPY As String, N As String
On Error Resume Next
myStr = StrConv(myStr, vbNarrow)
L = Len(myStr)excel口内打 或者x
For i = 1 To L
If Asc(Mid(myStr, i, 1)) > 0 Or Err.Number = 1004 Then N = ""
N = Application.WorksheetFunction.VLookup(Mid(myStr, i, 1), _
[{"吖","A";"八","B";"嚓","C";"咑","D";"鵽","E";"发","F";"猤","G";"铪","H";"夻","J";"咔","K";"垃","L";"嘸","M";"旀","N";"噢","O";"妑","P";"七","Q";"囕","R";"仨","S";"他","T";"屲","W";"夕","X";"丫","Y";"帀","Z"}], 2)
GetPY = GetPY & N
Next i
HYPY = GetPY
End Function
========================LOOKUP(CODE(A1),45217+{0,36,544,1101,1609,1793,2080,2560,2902,3845,4107,4679,5154,5397,5405,5689,6170,6229,7001,7481,7763,8472,9264},{"A","B","C","D","E","F","G","H","J","K","L","M","N","O","P","Q","R","S","T","W","X","Y","Z"})

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。