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

alzeng · 发表于 2009-8-4 12:03

本帖最后由 alzeng 于 2012-5-17 11:40 编辑

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

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

复制代码

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

Option Compare Text
Function PY(ByVal rng As Range)
Dim i%, k%, str$
str = Replace(Replace(rng, " ", ""), "　", "")
For i = 1 To Len(str)
If Not Mid(str, i, 1) Like "[一-龥]" Then
PY = PY & Mid(str, i, 1)
Else
k = 1
Do Until Mid("八嚓哒妸发旮铪讥讥咔垃妈拿哦妑七然仨他哇哇哇夕丫匝咗", k, 1) > Mid(str, i, 1)
k = k + 1
Loop
PY = PY & Chr(64 + k)
End If
Next
End Function

复制代码

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

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

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

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

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

大家试用有什么意见或建议，欢迎提出，以利修订，应用附件如下：

汉字转拼音函数及应用.rar (19.41 KB, 下载次数: 3554)

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

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

lhdcxz · 发表于 2009-8-4 12:33

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

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

alzeng · 发表于 2009-8-4 13:21

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

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

alzeng · 发表于 2009-8-4 13:23

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

lhdcxz · 发表于 2009-8-4 13:50

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

alzeng · 发表于 2009-8-4 14:03

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

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

李子然 · 发表于 2009-8-4 14:45

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

zldccmx · 发表于 2009-8-4 15:02

支持!
另外给个建议，建议实时关闭控件。
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 · 发表于 2009-8-4 15:03

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

zldccmx · 发表于 2009-8-4 15:08

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

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

		自动登录	找回密码
密码			免费注册

[原创] 汉字转拼音首字的函数及其灵活运用

点评

评分

回复 6楼 alzeng 的帖子