求一个中文小写自定义函数：函数中回避使用worksheetfunction

mzbao

上面代码小数只能认出2位，我重新从网上找了个代码完善了下：

1. Function CChinese(StrEng As String) As String
   
2.     If Not IsNumeric(StrEng) Then
   
3.         If Trim(StrEng) <> "" Then MsgBox "无效的数字"
   
4.         CChinese = "": Exit Function
   
5.     End If
   
6.    
   
7.     Dim intLen As Integer, intCounter As Integer
   
8.     Dim strCh As String, strTempCh As String
   
9.     Dim strSeqCh1 As String, strSeqCh2 As String
   
10.     Dim strEng2Ch As String, strDec As String
    
11.    
    
12.     strEng2Ch = "〇一二三四五六七八九"
    
13.     strSeqCh1 = " 十百千 十百千 十百千 十百千"
    
14.     strSeqCh2 = " 万亿兆"
    
15.    
    
16.     If InStr(StrEng, ".") Then strDec = Split(StrEng, ".")(1)
    
17.     StrEng = CStr(Int(StrEng))
    
18. 
    
19.     '整数部分
    
20.     intLen = Len(StrEng)
    
21.     For intCounter = 1 To intLen
    
22.         strTempCh = Mid(strEng2Ch, Val(Mid(StrEng, intCounter, 1)) + 1, 1)
    
23.         If strTempCh = "〇" And intLen <> 1 Then
    
24.             If Mid(StrEng, intCounter + 1, 1) = "0" Or (intLen - intCounter + 1) Mod 4 = 1 Then
    
25.                 strTempCh = ""
    
26.             End If
    
27.         Else
    
28.             strTempCh = strTempCh & Trim(Mid(strSeqCh1, intLen - intCounter + 1, 1))
    
29.         End If
    
30.    
    
31.         If (intLen - intCounter + 1) Mod 4 = 1 Then
    
32.             strTempCh = strTempCh & Mid(strSeqCh2, (intLen - intCounter + 1) \ 4 + 1, 1)
    
33.             If intCounter > 3 Then
    
34.                 If Mid(StrEng, intCounter - 3, 4) = "0000" Then strTempCh = Left(strTempCh, Len(strTempCh) - 1)
    
35.             End If
    
36.         End If
    
37.         strCh = strCh & Trim(strTempCh)
    
38.     Next
    
39.    
    
40.     '小数部分
    
41.     If Len(strDec) Then
    
42.         For i = 0 To 9
    
43.             strDec = Replace(strDec, i, Mid(strEng2Ch, i + 1, 1))
    
44.         Next
    
45.         strCh = strCh & "点" & strDec
    
46.     End If
    
47.    
    
48.     CChinese = strCh
    
49. End Function

复制代码

yjh_27

weiyingde 发表于 2020-3-2 14:38
那就凑合着用吧，学艺不精，只好将就着。

1. Function a2cc(s, Optional m = 0)
   
2. If s < 0 Then
   
3. t = "负"
   
4. s = -s
   
5. Else
   
6. t = ""
   
7. End If
   
8. 
   
9. yfl = Split(s, ".")
   
10. If m = 0 Then
    
11.     tm = Split("零 壹 贰 叁 肆 伍 陆 柒 捌 玖")
    
12. Else
    
13.     tm = Split("〇 一 二 三 四 五 六 七 八 九")
    
14. End If
    
15. If m = 0 Then
    
16.     tk = Split("亿 万 仟 佰 拾")
    
17. Else
    
18.     tk = Split("亿 万 千 百 十")
    
19. End If
    
20. 
    
21. L = Len(yfl(0)) - 1
    
22. t0 = 0.1
    
23. yi = L \ 8
    
24. ReDim y(yi)
    
25. For i = 0 To yi
    
26.     y(i) = Right(yfl(0), 8)
    
27.     If Len(yfl(0)) > 8 Then yfl(0) = Left(yfl(0), Len(yfl(0)) - 8)
    
28. Next
    
29. 
    
30. For i = yi To 0 Step -1
    
31.     LW = Len(y(i)) - 1
    
32.     wi = LW \ 4
    
33.     ReDim w(wi)
    
34.     For ii = 0 To wi
    
35.         w(ii) = Right(y(i), 4)
    
36.         If Len(y(i)) > 4 Then y(i) = Left(y(i), Len(y(i)) - 4)
    
37.     Next
    
38.     For ii = wi To 0 Step -1
    
39.         L = Len(w(ii))
    
40.         For iii = 1 To L
    
41.             t1 = Mid(w(ii), iii, 1)
    
42.             If t0 > 0 Or t1 > 0 Then
    
43.                  t = t & tm(t1)
    
44.                  L1 = L + 1 - iii
    
45.                  If t1 > 0 Then If L1 >= 2 And L1 <= 4 Then t = t & tk(6 - L1)
    
46.                  t0 = t1
    
47.             End If
    
48.         Next
    
49.         
    
50.         If ii > 0 Then
    
51.             If t0 = 0 Then
    
52.                 t = Mid(t, 1, Len(t) - 1) & tk(1) & tm(0)
    
53.             Else
    
54.                 t = t & tk(1)
    
55.             End If
    
56.         End If
    
57.     Next
    
58.     If i > 0 Then
    
59.         If t0 = 0 Then
    
60.             t = Mid(t, 1, Len(t) - 1) & tk(0) & tm(0)
    
61.         Else
    
62.             t = t & tk(0)
    
63.         End If
    
64.     End If
    
65. Next
    
66. 
    
67. If UBound(yfl) > 0 Then
    
68.     If t = "" Then
    
69.         t = tm(0) & "点"
    
70.     ElseIf Right(t, 1) = tm(0) Then
    
71.         Mid(t, Len(t), 1) = "点"
    
72.     Else
    
73.         t = t & "点"
    
74.     End If
    
75.     L = Len(yfl(1))
    
76.     For i = 1 To L
    
77.         t = t & tm(Mid(yfl(1), i, 1))
    
78.     Next
    
79. End If
    
80. t = Replace(t, tk(0) & tk(1), tk(0))
    
81. If Right(t, 1) = tm(0) Then t = Mid(t, 1, Len(t) - 1)
    
82. a2cc = t
    
83. End Function
    

复制代码

与楼下不同处101000     壹拾万零壹仟       一十万一千

1. 
   

复制代码

micch

牛，现写的吗？

mzbao

自己写了个。和上面的思路完全不一样。

1. Function NumToCN(ByVal ArabicNum) As String
   
2.     If Not IsNumeric(ArabicNum) Then
   
3.         If Trim(ArabicNum) <> "" Then NumToCN = "N/A" Else NumToCN = ""
   
4.         Exit Function
   
5.     End If
   
6.    
   
7.     Dim strInt&, strDec$, i%, strNumCN$, strTempCN$, strMinus$
   
8.    
   
9.     strNumCN = "〇一二三四五六七八九"
   
10.    
    
11.     If ArabicNum < 0 Then strMinus = "负"
    
12.     If InStr(ArabicNum, ".") Then strDec = Split(ArabicNum, ".")(1)
    
13.     ArabicNum = Int(Abs(ArabicNum))
    
14.     strTempCN = Format(ArabicNum, "0千0百0十0兆0千0百0十0亿0千0百0十0万0千0百0十0")
    
15.     For i = 1 To 3: strTempCN = Replace(strTempCN, 0 & Mid("千百十", i, 1), 0): Next
    
16.     For i = 1 To 3: strTempCN = Replace(strTempCN, "0000" & Mid("兆亿万", i, 1), ""): Next
    
17.     For i = 1 To 3: strTempCN = Replace(strTempCN, "00", 0): Next
    
18.     For i = 1 To 3: strTempCN = Replace(strTempCN, "0" & Mid("兆亿万", i, 1), Mid("兆亿万", i, 1)): Next
    
19.     If ArabicNum = 0 Then strTempCN = "〇"
    
20.     If Left(strTempCN, 1) = 0 Then strTempCN = Mid(strTempCN, 2)
    
21.     If Right(strTempCN, 1) = 0 Then strTempCN = Left(strTempCN, Len(strTempCN) - 1)
    
22. 
    
23.     If Len(strDec) Then strTempCN = strTempCN & "点" & strDec
    
24.     For i = 0 To 9: strTempCN = Replace(strTempCN, i, Mid(strNumCN, i + 1, 1)): Next
    
25.    
    
26.     NumToCN = strMinus & strTempCN
    
27. End Function

复制代码

weiyingde

yjh_27 发表于 2020-3-2 17:09

谢谢大侠，知道你的自定义函数做得好，果然出手不凡，谢谢啦。

weiyingde

mzbao 发表于 2020-3-2 19:13
自己写了个。和上面的思路完全不一样。

又收获一个，喜出望外。太感谢了。

weiyingde

两位的自定义函数，收进了我的帖子里。
见http://club.excelhome.net/thread-1397953-7-1.html 64、65楼。
未经同意，不知可否。

lss001

weiyingde 发表于 2020-3-2 14:29
你这是字母大小写吧？要实现1-一；2-二，3-三、4-四……这样的转换。

见4楼改正函数代码！！

weiyingde

lss001 发表于 2020-3-2 13:40
'*********************
Function numTotext(x)
Set ex = CreateObject("excel.application")

问一句，NUMBERSTRING是工作表函数吗。

lss001

weiyingde 发表于 2020-3-2 21:47
问一句，NUMBERSTRING是工作表函数吗。

NUMBERSTRING工作表非公开函数！