汉字转拼音首字的函数及其灵活运用

alzeng

搜索了论坛，有不少关于汉字转拼音首字的自定义函数，感觉大多都很繁琐。像以下这样的自定义函数比较简洁，只有寥寥几行，见论坛上没有，就发上来。
☆ 首先，谢谢朽大为我解惑，才使这个函数得以能应用，^_^
☆ 8月4日13:45 根据lhdcxz朋友的建议，做出代码调整，解除了空格显示为 A 的错误。
☆ 8月5日 4:53 根据朽大的建议，增加实时退出控件的代码。
☆ 2010年1月22日　查找音序表，更新了查询字串，原有的一些错误声母会得出修正。
☆ 2010年1月22日，应先行者朋友的要求，做了两点改进（附件同时更新）：
    ①　实际工作中有时会遇到同列的某些单元格不需要输入汉字的情况，响应回车键，按下回车键后跳到下一个单元格的位置上弹出下拉列表；
    ②　在工作表上面加上一个按钮，需要用时启用执行操作，不需要是按下禁用，这样就不会影响“复制”与“粘贴”的功能。

1. 
   
2. Option Compare Text
   
3. Function PY(ByVal rng As Range)
   
4.     Dim i%, k%, str$
   
5. 
   
6.     str = Replace(Replace(rng, " ", ""), "　", "")
   
7.     For i = 1 To Len(str)
   
8.         k = 1
   
9.         Do Until Mid("八嚓哒妸发旮铪讥讥咔垃妈拿哦妑七然仨他哇哇哇夕丫匝咗", k, 1) > Mid(str, i, 1)
   
10.             k = k + 1
    
11.         Loop
    
12.         PY = PY & Chr(64 + k)
    
13.     Next
    
14. End Function
    

复制代码

有朋友提出数字英文和汉字混合的情况下的全A问题，可以对代码稍做修改增加一个判断步骤实现：

1. 
   
2. Option Compare Text
   
3. Function PY(ByVal rng As Range)
   
4.     Dim i%, k%, str$
   
5. 
   
6.     str = Replace(Replace(rng, " ", ""), "　", "")
   
7.     For i = 1 To Len(str)
   
8.         If Not Mid(str, i, 1) Like "[一-龥]" Then
   
9.             PY = PY & Mid(str, i, 1)
   
10.         Else
    
11.             k = 1
    
12.             Do Until Mid("八嚓哒妸发旮铪讥讥咔垃妈拿哦妑七然仨他哇哇哇夕丫匝咗", k, 1) > Mid(str, i, 1)
    
13.                 k = k + 1
    
14.             Loop
    
15.             PY = PY & Chr(64 + k)
    
16.         End If
    
17.     Next
    
18. End Function
    

复制代码

关于这个函数的应用如下图：

日常工作中我们经常要输入部门人员的姓名，条条输入，不胜其繁。在这里，我做了多功能选择输入的一个应用实例，希望大家能够变通应用。
比方说我们在“输入”表中要快速输入“名册”中的姓名，就只需选择单元格，即可快速输入“名册”中已有的姓名。
①　常规选择　激活单元格后，用鼠标选择，即可快速录入：

②　输入标号　如果不便使用鼠标，直接输入姓名在ListBox1中的标号，即可快速录入：

②　综合输入与选择　如果ListBox1中条目过多，不做过滤，则选择多有不便。可以输入姓名中的拼音首字符（不分大小写），先行筛选后，然后输入标号（这个做法类似于输入法中的重码选择），即可快速录入（当然，你也可以用鼠标选择上屏）：

③　如果激活单元格后想退出，则可点击其他列或是输入一个空格（全半角均可）。

大家试用有什么意见或建议，欢迎提出，以利修订，应用附件如下：
汉字转拼音函数及应用.rar (19.41 KB, 下载次数: 3563)

2010-1-22 14:33 上传

点击文件名下载附件

[ 本帖最后由 alzeng 于 2010-1-22 14:37 编辑 ]

补充内容 (2016-4-16 17:08):
2016-04-16 关于多音字的容错替换应用，请参考156楼代码做相应的补充。

lhdcxz

太精华了！有点小问题。
咔嚓        结果为  JB  ？
咔 嚓        结果为  JAB  ？

[ 本帖最后由 lhdcxz 于 2009-8-4 12:58 编辑 ]

alzeng

原帖由 lhdcxz 于 2009-8-4 12:33 发表
太精华了！有点小问题。
咔嚓        结果为  JB  ？
咔 嚓        结果为  JAB  ？

这个通过修改字符串为 ："芭嚓搭蛾发噶哈击击咔垃妈拿哦啪期然撒塌挖挖挖昔压匝咗" ，可以得到修正。困惑在于根据狼版提供的码表，擦<嚓，喀<咔，不知为什么会出现这个情况。
而作为姓名输入的应用中，我认为可以不考虑这些不用于人名的字的特殊情况，^_^

alzeng

咔 嚓 ，这种中有空格的方式在这里没有设置容错，在实际应用中，我认为这种情形是不应该出现的。

lhdcxz

在实际应用里，可能有要求“双名中间要有空格”。所以您最好能处理中有空格的方式。

alzeng

原帖由 lhdcxz 于 2009-8-4 13:50 发表
在实际应用里，可能有要求“双名中间要有空格”。所以您最好能处理中有空格的方式。

我在这里做了剔除处理，附件及代码已重修正。

李子然

不错的应用，如果是多列都要实现这样的效果要怎么办呢？因为这样感觉更实用些，请指教

zldccmx

支持!
另外给个建议，建议实时关闭控件。
Private Sub Worksheet_SelectionChange(ByVal Target As Range )
   If Target.Column > 1 Or Target.Row = 1 Or Target.Cells.Count > 1 Then TextBox1.Visible = False: ListBox1.Visible = False: Exit Sub
    With TextBox1
        .Activate
        .Visible = True
        .Value = ""
        .Top = Target.Top
        .Left = Target.Left
        .Width = Target.Width + 20
        .Height = Target.Height
    End With
    With ListBox1
        .Visible = True
        .Top = Target.Offset(1).Top
        .Left = Target.Left
        .Width = Target.Width + 20
        .Height = Target.Height * 10
    End With
End Sub

lhdcxz

我想，可能楼主专家的代码现在还是“测试版”，以后也许会考虑的。

zldccmx

        Do Until Mid("芭嚓搭蛾发噶哈击击咔垃妈拿哦啪期然撒塌挖挖挖昔压匝咗", k, 1) > Mid(str, i, 1)

存在双击三挖？为什么T要用34个汉字？