小写数字转中文大写或中文金额

mjzxlmg

1. Option Explicit
   
2. Private Const ChnGenText As String = "零一二三四五六七八九"
   
3. Private Const ChnRMBText As String = "零壹贰叁肆伍陆柒捌玖"
   
4. Private Const ChnGenDigit As String = "十百千万亿"
   
5. Private Const ChnRMBDigit As String = "拾佰仟万亿"
   
6. Private Const ChnRMBUnit As String = "角分"
   
7.     ''' <summary>
   
8.     ''' 主转换函数
   
9.     ''' </summary>
   
10.     ''' <param name="strDigit">待转换数字字符串</param>
    
11.     ''' <param name="bToRMB">是否转换成人民币</param>
    
12.     ''' <returns>转换成的大写字符串</returns>
    
13.     Public Function ConvertChn(ByVal strDigit As String, Optional ByVal bToRMB As Boolean = False) As String
    
14.         Dim ErrStr As String
    
15.         If CheckDigit(strDigit, bToRMB, ErrStr) Then ' 检查输入数字有效性
    
16.             If bToRMB Then
    
17.                 Dim indexOfPoint As Integer
    
18.                 indexOfPoint = InStr(strDigit, ".")
    
19.                 If indexOfPoint Then strDigit = Round(Val(strDigit), 2)
    
20.             End If
    
21.             Dim strResult As String
    
22.             Call ExtractSign(strResult, strDigit, bToRMB)
    
23.             Call ConvertNumber(strResult, strDigit, bToRMB)
    
24.             ConvertChn = strResult
    
25.         Else
    
26.             ConvertChn = ErrStr
    
27.         End If
    
28.     End Function
    
29.    
    
30.     Private Sub ConvertNumber(ByRef strResult As String, ByVal strDigit As String, ByVal bToRMB As Boolean)
    
31.         Dim indexOfPoint As Integer
    
32.         indexOfPoint = InStr(strDigit, ".")
    
33.         If indexOfPoint = 0 Then
    
34.             strResult = strResult & ConvertIntegral(strDigit, bToRMB)
    
35.             If bToRMB Then strResult = strResult & "圆整"
    
36.         Else
    
37.             If indexOfPoint = 1 Then
    
38.                 If Not bToRMB Then strResult = strResult & "零"
    
39.             Else
    
40.                 strResult = strResult & ConvertIntegral(Left(strDigit, indexOfPoint - 1), bToRMB)
    
41.             End If
    
42.             If Len(strDigit) <> indexOfPoint Then
    
43.                 If bToRMB Then
    
44.                     If indexOfPoint <> 1 Then
    
45.                         If Len(strResult) = 1 And strResult = "零" Then
    
46.                             strResult = Replace(strResult, "零", "")
    
47.                         Else
    
48.                             strResult = strResult & "圆"
    
49.                         End If
    
50.                     End If
    
51.                 Else
    
52.                     strResult = strResult & "点"
    
53.                 End If
    
54.                 Dim strTmp As String
    
55.                 strTmp = ConvertFractional(Mid(strDigit, indexOfPoint + 1, Len(strDigit)), bToRMB)
    
56.                 If Len(strTmp) <> 0 Then
    
57.                     If bToRMB And Len(strResult) = 0 And Left(strTmp, 1) = "零" Then
    
58.                         strResult = strResult & Mid(strTmp, 2, Len(strTmp))
    
59.                     Else
    
60.                         strResult = strResult & strTmp
    
61.                     End If
    
62.                 End If
    
63.                 If bToRMB Then
    
64.                     If Len(strResult) = 0 Then
    
65.                         strResult = strResult & "零圆整"
    
66.                     ElseIf Right(strResult, 1) = "圆" Then
    
67.                         strResult = strResult & "整"
    
68.                     End If
    
69.                 End If
    
70.             ElseIf bToRMB Then
    
71.                 strResult = strResult & "圆整"
    
72.             End If
    
73.         End If
    
74.     End Sub
    
75.    
    
76. Private Function CheckDigit(ByRef strDigit As String, ByVal bToRMB As Boolean, Optional ByRef ErrStr As String = "") As Boolean
    
77.         Dim isValidate As Boolean
    
78.         If IsNumeric(strDigit) Then
    
79.             isValidate = True
    
80.         Else
    
81.             ErrStr = "输入数字的格式不正确！"
    
82.             isValidate = False
    
83.         End If
    
84.         If bToRMB Then
    
85.             If Val(strDigit) >= 1E+16 Then
    
86.                 ErrStr = "输入数字太大，超出转换范围！"
    
87.                 isValidate = False
    
88.             ElseIf Val(strDigit) < 0 Then
    
89.                 ErrStr = "不允许人民币为负值！"
    
90.                 isValidate = False
    
91.             End If
    
92.         Else
    
93.             If Val(strDigit) <= -1E+16 Or Val(strDigit) >= 1E+16 Then
    
94.                 ErrStr = "输入数字太大或太小，超出转换范围！"
    
95.                 isValidate = False
    
96.             Else
    
97.                 isValidate = True
    
98.             End If
    
99.         End If
    
100.         CheckDigit = isValidate
     
101.     End Function
     
102.    
     
103.     Private Sub ExtractSign(ByRef strResult As String, ByRef strDigit As String, ByVal bToRMB As Boolean)
     
104.         If Left(strDigit, 1) = "+" Then
     
105.             strDigit = Mid(strDigit, 2, Len(strDigit))
     
106.         ElseIf Left(strDigit, 1) = "-" Then
     
107.             If Not bToRMB Then strResult = strResult & "负"
     
108.             strDigit = Mid(strDigit, 2, Len(strDigit))
     
109.         ElseIf Right(strDigit, 1) = "+" Then
     
110.             strDigit = Left(strDigit, Len(strDigit) - 1)
     
111.         ElseIf Right(strDigit, 1) = "-" Then
     
112.             If Not bToRMB Then strResult = strResult & "负"
     
113.             strDigit = Left(strDigit, Len(strDigit) - 1)
     
114.         End If
     
115.     End Sub
     
116.    
     
117. Private Function ConvertIntegral(ByVal strIntegral As String, ByVal bToRMB As Boolean) As String
     
118.         Dim i As Integer, j As Integer, mylen As Integer, digit As Integer, mymod As Integer, index As Integer
     
119.         Dim strInt As String, chnText As String, chnDigit As String, strTemp As String
     
120.         Dim bDoSomething As Boolean
     
121.         mylen = Len(strIntegral)
     
122.         digit = mylen - 1
     
123.         chnText = IIf(bToRMB, ChnRMBText, ChnGenText)
     
124.         chnDigit = IIf(bToRMB, ChnRMBDigit, ChnGenDigit)
     
125.         For i = 1 To mylen - 1
     
126.             index = Val(Mid(strIntegral, i, 1)) + 1
     
127.             strInt = strInt & Mid(chnText, index, 1)
     
128.             mymod = digit Mod 4
     
129.             If mymod = 0 Then
     
130.                 If digit = 4 Or digit = 12 Then
     
131.                     strInt = strInt & Mid(chnDigit, 4, 1)
     
132.                 ElseIf digit = 8 Then
     
133.                     strInt = strInt & Mid(chnDigit, 5, 1)
     
134.                 End If
     
135.             Else
     
136.                 strInt = strInt & Mid(chnDigit, mymod, 1)
     
137.             End If
     
138.             digit = digit - 1
     
139.         Next
     
140.         index = Val(Mid(strIntegral, mylen, 1)) + 1
     
141.         If Right(strIntegral, 1) <> "0" Or mylen = 1 Then strInt = strInt & Mid(chnText, index, 1)
     
142.         i = 0
     
143. skip:
     
144.         Do While i < Len(strInt)
     
145.             j = i
     
146.             bDoSomething = False
     
147.             Do While j < Len(strInt) - 1 And Mid(strInt, j + 1, 1) = "零"
     
148.                 strTemp = Mid(strInt, j + 2, 1)
     
149.                 If Mid(chnDigit, 4, 1) = strTemp Or Mid(chnDigit, 5, 1) = strTemp Then
     
150.                     bDoSomething = True
     
151.                     Exit Do
     
152.                 End If
     
153.                 j = j + 2
     
154.             Loop
     
155.             If j <> i Then
     
156.                 strInt = Left(strInt, i) & Mid(strInt, j + 1)
     
157.                 If i <= Len(strInt) - 1 And Not bDoSomething Then
     
158.                     strInt = Left(strInt, i) & "零" & Mid(strInt, i + 1)
     
159.                     i = i + 1
     
160.                 End If
     
161.             End If
     
162.             If bDoSomething Then
     
163.                 strInt = Left(strInt, i) & Mid(strInt, i + 2)
     
164.                 i = i + 1
     
165.                 GoTo skip
     
166.             End If
     
167.             i = i + 2
     
168.         Loop
     
169.         strTemp = Mid(chnDigit, 5, 1) & Mid(chnDigit, 4, 1)
     
170.         index = InStr(strInt, strTemp)
     
171.         If index <> 0 Then
     
172.             If Len(strInt) - 1 <> index And index + 1 < Len(strInt) And Mid(strInt, index + 2, 1) <> "零" Then
     
173.                 strInt = Left(strInt, index - 1) & Mid(chnDigit, 5, 1) & Mid(strInt, index + 2)
     
174.                 strInt = Left(strInt, index) & "零" & Mid(strInt, index + 1)
     
175.             Else
     
176.                 strInt = Left(strInt, index - 1) & Mid(chnDigit, 5, 1) & Mid(strInt, index + 2)
     
177.             End If
     
178.         End If
     
179.         If Not bToRMB Then
     
180.             If Len(strInt) > 1 And Left(strInt, 2) = "一十" Then strInt = Mid(strInt, 2)
     
181.         End If
     
182.         ConvertIntegral = strInt
     
183.     End Function
     
184.    
     
185. Private Function ConvertFractional(ByVal strFractional As String, ByVal bToRMB As Boolean) As String
     
186.         Dim i As Integer, mylen As Integer, index As Integer
     
187.         Dim strFrac As String
     
188.         mylen = Len(strFractional)
     
189.         If bToRMB Then
     
190.             For i = 1 To mylen
     
191.                 index = Val(Mid(strFractional, i, 1)) + 1
     
192.                 strFrac = strFrac & Mid(ChnRMBText, index, 1)
     
193.                 strFrac = strFrac & Mid(ChnRMBUnit, i, 1)
     
194.             Next
     
195.             If Mid(strFrac, Len(strFrac) - 1, 2) = "零分" Then strFrac = Left(strFrac, Len(strFrac) - 2)
     
196.             If Left(strFrac, 2) = "零角" Then
     
197.                 If Len(strFrac) = 2 Then
     
198.                     strFrac = Mid(strFrac, 3)
     
199.                 Else
     
200.                     strFrac = Replace(strFrac, "角", "")
     
201.                 End If
     
202.             End If
     
203.         Else
     
204.             For i = 1 To mylen
     
205.                 index = Val(Mid(strFractional, i, 1)) + 1
     
206.                 strFrac = strFrac & Mid(ChnGenText, index, 1)
     
207.             Next
     
208.         End If
     
209.         ConvertFractional = strFrac
     
210.     End Function
     
211. 
     
212. Sub test()
     
213.     MsgBox ConvertChn("700010009.995", True)
     
214. End Sub

复制代码

201228

这么长吗？是不是得考虑很多细节问题

wode154808100

=IF(A1<0,"负","")&IF(ABS(A1)>1,TEXT(TRUNC(ABS(ROUND(A1,2))),"[DBNum2]")&"元","")&IF(ISERR(FIND(".",ROUND(A1,2))),"",TEXT(RIGHT(TRUNC(ROUND(A1,2)*10)),"[DBNum2]"))&IF(ISERR(FIND(".0",TEXT(A1,"0.00"))),"角","")&IF(LEFT(RIGHT(ROUND(A1,2),3))=".",TEXT(RIGHT(ROUND(A1,2)),"[DBNum2]")&"分","整")

mjzxlmg

wode154808100 发表于 2018-6-5 09:09
=IF(A11,TEXT(TRUNC(ABS(ROUND(A1,2))),"[DBNum2]")&"元","")&IF(ISERR(FIND(".",ROUND(A1,2))),"",TEXT(RI ...

上面的代码没有用工作表函数，可用在VB中，也可用在VBA中，灵活性较强。

mjzxlmg

201228 发表于 2018-6-5 09:04
这么长吗？是不是得考虑很多细节问题

主要是考虑中国人的习惯

201228

mjzxlmg 发表于 2018-6-5 11:38
主要是考虑中国人的习惯

嗷奥，谢谢大神回复

jjmysjg

谢谢楼主，这个怎么使用？

mjzxlmg

jjmysjg 发表于 2018-6-6 22:11
谢谢楼主，这个怎么使用？

Sub test()
MsgBox ConvertChn("700010009.995", True)
End Sub