我的自定义函数库——压箱底的宝贝拿出来跟大家分享一下！

maozhe

1. '汉字转拼音首字函数
   
2. Function Py(ByVal x As String) As String
   
3.     On Error Resume Next
   
4.     Dim i As Integer
   
5.     For i = 1 To Len(x)
   
6.         If Mid(x, i, 1) <> " " And Asc(Mid(x, i, 1)) < 0 Then Py = Py & Mid("ABCDEFGHJKLMNOPQRSTWXYZZ", Evaluate("MATCH(" & Asc(Mid(x, i, 1)) & ",{-20319,-20283,-19775,-19218,-18710,-18526,-18239,-17922,-17417,-16474,-16212,-15640,-15165,-14922,-14914,-14630,-14149,-14090,-13318,-12838,-12556,-11847,-11055,-10247},1)"), 1)
   
7.     Next
   
8. 
   
9. End Function

复制代码

maozhe

1. '提取批注文字函数：只有一个参数，即单元格引用。
   
2. Function Pz(Rng As Range) As String
   
3.     If Not Rng(1).Comment Is Nothing Then
   
4.         Pz = "[" & Rng.Address(RowAbsolute:=False, ColumnAbsolute:=False) & "] " & Rng(1).Comment.Text
   
5.     Else
   
6.         Pz = ""
   
7.     End If
   
8. End Function
   
9. 
   
10. '提取单元格中的公式，只需要一个参数，即单元格引用。
    
11. Function Gs(Rng As Range)
    
12.     Application.Volatile
    
13.     If Rng(1).HasFormula = False Then Gs = "": Exit Function
    
14.     If Rng(1).HasArray = True Then Gs = "{" & Rng(1).Formula & "}": Exit Function
    
15.     Gs = Rng.Formula
    
16. End Function
    

复制代码

maozhe

1. Public Function fanyi(Rng As String)
   
2.     Dim xml
   
3.     Dim URL$, EngSentence$
   
4.     Set xml = CreateObject("MSXML2.XMLHTTP")
   
5.     aasc = Asc(Rng)
   
6.     If aasc > 64 And aasc < 123 Then
   
7.         URL = "enN&tl=zh-CN&ie=UTF-8&prev=_m&q=" & Rng
   
8.     Else
   
9.         URL = "zh-CN&tl=enN&ie=UTF-8&prev=_m&q=" & GetURL(Rng)
   
10.     End If
    
11.     URL = "https://translate.google.cn/m?hl=en&sl=" & URL
    
12.     With xml
    
13.         .Open "GET", URL, False
    
14.         .send
    
15.         V = .responseText
    
16.         If InStr(V, "t0"">") > 0 Then
    
17.             fanyi = Split(Split(V, "t0"">")(1), "<")(0)
    
18.         End If
    
19.     End With
    
20. End Function
    
21. 
    
22. Function ChrU(txt)
    
23.     txt = "\u6666" & txt
    
24.     Sr = Split(txt, "\u") '按汉字单位拆分
    
25.     For i = 0 To UBound(Sr) '遍历
    
26.         If Len(Sr(i)) > 3 Then Sr(i) = ChrW("&H" & Left(Sr(i), 4)) & Mid(Sr(i), 5)
    
27.         '如果4个字符以上 则取前4个字符(汉字的16进制国际双位码值) 添加"&H"转为16进制数
    
28.         '然后用ChrW函数即可返回汉字
    
29.     Next
    
30.     ChrU = Mid(Join(Sr, ""), 2) '把转换后的汉字以及其余字符合并起来返回
    
31. End Function
    
32. 
    
33. Function sjc$() '时间戳
    
34.     'sjc = (Now - 25569 - 1 / 3) * 86400
    
35.     sjc = (Now - 25570 + 2 / 3) * 86400 + 100
    
36.     sjc = "=" & Left(sjc & Rnd * 100000, 13)
    
37.     'Debug.Print sjc
    
38. End Function
    
39. 
    
40. Function GetURL$(txt$)
    
41.     'Dim a() As Byte
    
42.     'a = StrConv(txt, vbFromUnicode, &H804)
    
43.     For i = 1 To Len(txt)
    
44.         txt1 = Mid(txt, i, 1)
    
45.         If Abs(Asc(txt1)) < 128 Then
    
46.             GetURL = GetURL & txt1
    
47.         Else
    
48.             GetURL1 = Application.Hex2Bin(Left(Hex(AscW(txt1)), 2), 8)
    
49.             GetURL1 = GetURL1 & Application.Hex2Bin(Right(Hex(AscW(txt1)), 2), 8)
    
50.             GetURL1 = Application.Replace(Application.Replace(GetURL1, 11, , 10), 5, , 10)
    
51.             GetURL2 = "%E" & Application.Bin2Hex(Left(GetURL1, 4))
    
52.             GetURL2 = GetURL2 & "%" & Application.Bin2Hex(Mid$(GetURL1, 5, 8))
    
53.             GetURL2 = GetURL2 & "%" & Application.Bin2Hex(Mid$(GetURL1, 13, 8))
    
54.             GetURL = GetURL & GetURL2
    
55.         End If
    
56.     Next
    
57. End Function
    
58. '如果一律转码是: GetURL = GetURL & "%" & Right("0" & Hex(a(i)), 2)
    
59. 
    
60. 
    
61. 
    

复制代码

lukeluckc

maozhe 发表于 2020-1-12 10:22
'人民币金额大写函数
Function DX(M)
    a = (IIf(Abs(M) < 0.005, "", Replace(Replace(Replace(Join(A ...

这个自定义函数中  Format（M,"0. 00"） 点后面的0为什么需要一个空格 没有这个空格则失败？

10307951261

留个脚印，用时备查

125675117

不会用啊，有没有做好的excel，谢谢

eccgrid

maozhe 发表于 2020-1-12 10:26

反馈下：汉字转拼音对一些字无效，比如偲

你是那块小饼干

感谢分享，楼主大大好人