Option Explicit
Public Function NumberToCharacter(number As String) As String
'完成转换的主函数
Dim Pos_Point As Long '记录小数点的位置
Dim curNum As String '记录当前处理的数字
Dim zhengshu As String '记录整数部分
Dim shuduan As String '截取某一个数据段
'检索小数点的位置
Pos_Point = InStr(number, ".")
'处理小数部分
If Pos_Point = 0 Then
'没有小数点,将小数点设置在最末尾
Pos_Point = Len(number)
ElseIf Len(number) = Pos_Point Then
'以小数点结尾,不作处理
ElseIf Len(number) = Pos_Point + 1 Then
'一位小数,直接翻译为角
curNum = Right(number, 1)
NumberToCharacter = NumToChr(curNum) & "角"
ElseIf Len(number) = Pos_Point + 2 Then
'取第一位
curNum = Right(number, 1)
'若第一位为零,则不作处理,否则译为“角”
If curNum <> "0" Then
NumberToCharacter = NumToChr(curNum) & "分"
End If
'取第二位
curNum = Left(Right(number, 2), 1)
'若第二为零,不作处理,否则译为“分”
If curNum <> "0" Then
NumberToCharacter = NumToChr(curNum) & "角" & NumberToCharacter
End If
End If
'处理整数
zhengshu = ""
If Pos_Point > 14 Then
'大于 9999999999999 的数据不转换
MsgBox "该数据无法转换", vbOKOnly + vbInformation, "金额转换"
Exit Function
ElseIf Pos_Point > 9 Then
zhengshu = "亿"
'亿位以上的部分
shuduan = Left(number, Pos_Point - 9)
zhengshu = shuduantoCharacter(shuduan) & zhengshu
'万位以上的部分
shuduan = Right(Left(number, Pos_Point - 5), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "万"
'万位以下部分
shuduan = Right(Left(number, Pos_Point - 1), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "圆"
ElseIf Pos_Point > 5 Then
'万位以上的部分
shuduan = Right(Left(number, Pos_Point - 5), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "万"
'万位以下部分
shuduan = Right(Left(number, Pos_Point - 1), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "圆"
Else
'万位以下
shuduan = Right(Left(number, Pos_Point - 1), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "圆"
End If
NumberToCharacter = zhengshu & NumberToCharacter
'输入为“0”,特殊处理
If NumberToCharacter = "圆" Then
NumberToCharacter = "零圆"
End If
End Function
Public Function NumToChr(num As String) As String
'数字转化为对应的中文
Select Case num
Case "1"
NumToChr = "壹"
Case "2"
NumToChr = "贰"
Case "3"
NumToChr = "参"
Case "4"
NumToChr = "肆"
Case "5"
NumToChr = "伍"
Case "6"
NumToChr = "陆"
Case "7"
NumToChr = "柒"
Case "8"
NumToChr = "捌"
Case "9"
NumToChr = "玖"
Case "0"
NumToChr = "零"
End Select
End Function
'对分节后的每一节数据进行翻译,
'例如: 1234512341234被分为12345,1234,1234
Public Function shuduantoCharacter(duan As String) As String
Dim curNum As String
Dim answer As String
answer = ""
If Len(duan) = 5 Then
'有万位
answer = NumToChr(Left(duan, 1)) & "万"
'千位
curNum = Right(Left(duan, 2), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "仟"
Else
answer = answer & "零"
End If
'百位
curNum = Right(Left(duan, 3), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "佰"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'十位
curNum = Right(Left(duan, 4), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "拾"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 4 Then
'有千位
answer = NumToChr(Left(duan, 1)) & "仟"
'百位
curNum = Left(Right(duan, 3), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "佰"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'十位
curNum = Left(Right(duan, 2), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "拾"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 3 Then
'有百位
answer = NumToChr(Left(duan, 1)) & "佰"
'十位
curNum = Left(Right(duan, 2), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "拾"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 2 Then
'有十位
answer = NumToChr(Left(duan, 1)) & "拾"
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 1 Then
'有个位
answer = NumToChr(Left(duan, 1))
End If
shuduantoCharacter = answer
End Function
Public Function NumberToCharacter(number As String) As String
'完成转换的主函数
Dim Pos_Point As Long '记录小数点的位置
Dim curNum As String '记录当前处理的数字
Dim zhengshu As String '记录整数部分
Dim shuduan As String '截取某一个数据段
'检索小数点的位置
Pos_Point = InStr(number, ".")
'处理小数部分
If Pos_Point = 0 Then
'没有小数点,将小数点设置在最末尾
Pos_Point = Len(number)
ElseIf Len(number) = Pos_Point Then
'以小数点结尾,不作处理
ElseIf Len(number) = Pos_Point + 1 Then
'一位小数,直接翻译为角
curNum = Right(number, 1)
NumberToCharacter = NumToChr(curNum) & "角"
ElseIf Len(number) = Pos_Point + 2 Then
'取第一位
curNum = Right(number, 1)
'若第一位为零,则不作处理,否则译为“角”
If curNum <> "0" Then
NumberToCharacter = NumToChr(curNum) & "分"
End If
'取第二位
curNum = Left(Right(number, 2), 1)
'若第二为零,不作处理,否则译为“分”
If curNum <> "0" Then
NumberToCharacter = NumToChr(curNum) & "角" & NumberToCharacter
End If
End If
'处理整数
zhengshu = ""
If Pos_Point > 14 Then
'大于 9999999999999 的数据不转换
MsgBox "该数据无法转换", vbOKOnly + vbInformation, "金额转换"
Exit Function
ElseIf Pos_Point > 9 Then
zhengshu = "亿"
'亿位以上的部分
shuduan = Left(number, Pos_Point - 9)
zhengshu = shuduantoCharacter(shuduan) & zhengshu
'万位以上的部分
shuduan = Right(Left(number, Pos_Point - 5), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "万"
'万位以下部分
shuduan = Right(Left(number, Pos_Point - 1), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "圆"
ElseIf Pos_Point > 5 Then
'万位以上的部分
shuduan = Right(Left(number, Pos_Point - 5), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "万"
'万位以下部分
shuduan = Right(Left(number, Pos_Point - 1), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "圆"
Else
'万位以下
shuduan = Right(Left(number, Pos_Point - 1), 4)
zhengshu = zhengshu & shuduantoCharacter(shuduan) & "圆"
End If
NumberToCharacter = zhengshu & NumberToCharacter
'输入为“0”,特殊处理
If NumberToCharacter = "圆" Then
NumberToCharacter = "零圆"
End If
End Function
Public Function NumToChr(num As String) As String
'数字转化为对应的中文
Select Case num
Case "1"
NumToChr = "壹"
Case "2"
NumToChr = "贰"
Case "3"
NumToChr = "参"
Case "4"
NumToChr = "肆"
Case "5"
NumToChr = "伍"
Case "6"
NumToChr = "陆"
Case "7"
NumToChr = "柒"
Case "8"
NumToChr = "捌"
Case "9"
NumToChr = "玖"
Case "0"
NumToChr = "零"
End Select
End Function
'对分节后的每一节数据进行翻译,
'例如: 1234512341234被分为12345,1234,1234
Public Function shuduantoCharacter(duan As String) As String
Dim curNum As String
Dim answer As String
answer = ""
If Len(duan) = 5 Then
'有万位
answer = NumToChr(Left(duan, 1)) & "万"
'千位
curNum = Right(Left(duan, 2), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "仟"
Else
answer = answer & "零"
End If
'百位
curNum = Right(Left(duan, 3), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "佰"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'十位
curNum = Right(Left(duan, 4), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "拾"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 4 Then
'有千位
answer = NumToChr(Left(duan, 1)) & "仟"
'百位
curNum = Left(Right(duan, 3), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "佰"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'十位
curNum = Left(Right(duan, 2), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "拾"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 3 Then
'有百位
answer = NumToChr(Left(duan, 1)) & "佰"
'十位
curNum = Left(Right(duan, 2), 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum) & "拾"
Else
If Right(answer, 1) <> "零" Then
answer = answer & "零"
End If
End If
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 2 Then
'有十位
answer = NumToChr(Left(duan, 1)) & "拾"
'个位
curNum = Right(duan, 1)
If curNum <> "0" Then
answer = answer & NumToChr(curNum)
Else
If Right(answer, 1) = "零" Then
answer = Left(answer, Len(answer) - 1)
End If
End If
ElseIf Len(duan) = 1 Then
'有个位
answer = NumToChr(Left(duan, 1))
End If
shuduantoCharacter = answer
End Function