小写人民币转大写

'源程序如下： 
Option Explicit 

Public Function NumberToCharacter()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()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()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