[分享]人民币金额大写

守柔 · 发表于 2005-3-23 17:25

看来网友们对于WORD中的人民币金额大写非常感兴趣，兴之所致，也做了一个。

当然，网友hlrong的相当不错（我并不抄袭之心，也没有必要）见此链接：http://club.excelhome.net/viewthread.php?tid=37843

就想起了李白与崔颢一段史事。崔颢的〈黄鹤楼〉：昔人已乘黄鹤去，此地空余黄鹤楼。黄鹤一去不复返，白云千载空悠悠。晴川历历汉阳树，芳草萋萋鹦鹉洲。日暮乡关何处是，烟波江上使人愁。

李白后来写了一首〈凤凰台〉

凤凰台前凤凰游，凤去台空江自流。吴宫花草埋幽径，晋代衣冠成古丘。三山半落青天外，二水中分白鹭洲。总为浮去能蔽日，长安不见使人愁。

信口背了一下，可能有所误，看官见笑了。

以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-3-23 17:23:49
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit
Sub GetChineseNum2()
    Dim Numeric As Currency, IntPart As Long, DecimalPart As Byte, MyField As Field, Lable As String
    Dim Jiao As Byte, Fen As Byte, Oddment As String, Odd As String, MyChinese As String
    Const ZWDX As String = "壹贰叁肆伍陆柒捌玖零"    '定义一个中文大写汉字常量
    On Error Resume Next    '错误忽略
    With Selection
        Numeric = VBA.Round(VBA.Val(.Text), 2)    '四舍五入保留小数点后两位
        '判断是否在表格中
        If .Information(wdWithInTable) Then _
.MoveRight unit:=wdCell Else .MoveRight unit:=wdCharacter
        '对数据进行判断,是否在指定的范围内
        If VBA.Abs(Numeric) > 2147483647 Then MsgBox "数值超过范围!", _
                                                     vbOKOnly + vbExclamation, "Warning": Exit Sub
        IntPart = Int(VBA.Abs(Numeric))    '定义一个正整数
        Odd = VBA.IIf(IntPart = 0, "", "圆")    '定义一个STRING变量
        '插入中文大写前的标签
        Lable = VBA.IIf(Numeric = VBA.Abs(Numeric), "人民币金额大写:　", "人民币金额大写:　负")
        '对小数点后面二位数进行择定
        DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100
        Select Case DecimalPart
        Case Is = 0    '如果是0,即是选定的数据为整数
            Oddment = VBA.IIf(Odd = "", "", Odd & "整")
        Case Is < 10    '<10,即是零头是分
            Oddment = VBA.IIf(Odd <> "", "圆零" & VBA.Mid(ZWDX, DecimalPart, 1) & "分", _
                              VBA.Mid(ZWDX, DecimalPart, 1) & "分")
        Case 10, 20, 30, 40, 50, 60, 70, 80, 90    '如果是角整
            Oddment = "圆" & VBA.Mid(ZWDX, DecimalPart / 10, 1) & "角整"
        Case Else    '既有角,又有分的情况
            Jiao = VBA.Left(CStr(DecimalPart), 1)    '取得角面值
            Fen = VBA.Right(CStr(DecimalPart), 1)    '取得分面值
            Oddment = Odd & VBA.Mid(ZWDX, Jiao, 1) & "角"    '转换为角的中文大写
            Oddment = Oddment & VBA.Mid(ZWDX, Fen, 1) & "分"    '转换为分的中文大写
        End Select
        '指定区域插入中文大写格式的域
        Set MyField = .Fields.Add(Range:=.Range, Text:="= " & IntPart & " \*CHINESENUM2")
        MyField.Select    '选定域(最后是用指定文本覆盖选定区域)
        '如果仅有角分情况下,Mychinese为""
        MyChinese = VBA.IIf(MyField.Result <> "零", MyField.Result, "")
        .Text = Lable & MyChinese & Oddment
    End With
End Sub
'----------------------

说明：可以选定的文本数据后面插入此金额大写，如果选定范围在表格中，则在右侧单元格中插入金额大写。

最大金额绝对值不得超过2147483647

请点击“金额大写”命令（在格式工具栏中）

请下载此作品：

最新作品《守柔Word数字通》修正了原程序中的多种不足与BUG，欢迎测试！ [ 本帖最后由守柔于 2009-4-11 13:42 编辑 ]

liyh67 · 发表于 2005-3-23 20:50

已下载，学习中……

守柔 · 发表于 2005-3-24 08:57

略作进一步修饰：

以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-3-24 08:56:27 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub GetChineseNum2() Dim Numeric As Currency, IntPart As Long, DecimalPart As Byte, MyField As Field, Lable As String Dim Jiao As Byte, Fen As Byte, Oddment As String, Odd As String, MyChinese As String Const ZWDX As String = "壹贰叁肆伍陆柒捌玖零" '定义一个中文大写汉字常量 On Error GoTo ErrHandle '错误处理 With Selection If .Type = wdSelectionIP Then MsgBox "请选定需要转换的文本数据!", _ vbOKOnly + vbInformation: Exit Sub Numeric = VBA.Round(VBA.Val(.Text), 2) '四舍五入保留小数点后两位 '判断是否在表格中 If .Information(wdWithInTable) Then _ .MoveRight unit:=wdCell Else .MoveRight unit:=wdCharacter '对数据进行判断,是否在指定的范围内 IntPart = Int(VBA.Abs(Numeric)) '定义一个正整数 Odd = VBA.IIf(IntPart = 0, "", "圆") '定义一个STRING变量 '插入中文大写前的标签 Lable = VBA.IIf(Numeric = VBA.Abs(Numeric), "　人民币金额大写:　", "　人民币金额大写:　负") '对小数点后面二位数进行择定 DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100 Select Case DecimalPart Case Is = 0 '如果是0,即是选定的数据为整数 Oddment = VBA.IIf(Odd = "", "", Odd & "整") Case Is < 10 '<10,即是零头是分 Oddment = VBA.IIf(Odd <> "", "圆零" & VBA.Mid(ZWDX, DecimalPart, 1) & "分", _ VBA.Mid(ZWDX, DecimalPart, 1) & "分") Case 10, 20, 30, 40, 50, 60, 70, 80, 90 '如果是角整 Oddment = "圆" & VBA.Mid(ZWDX, DecimalPart / 10, 1) & "角整" Case Else '既有角,又有分的情况 Jiao = VBA.Left(CStr(DecimalPart), 1) '取得角面值 Fen = VBA.Right(CStr(DecimalPart), 1) '取得分面值 Oddment = Odd & VBA.Mid(ZWDX, Jiao, 1) & "角" '转换为角的中文大写 Oddment = Oddment & VBA.Mid(ZWDX, Fen, 1) & "分" '转换为角分的中文大写 End Select '指定区域插入中文大写格式的域 Application.ScreenUpdating = False '关闭屏幕更新 Set MyField = .Fields.Add(Range:=.Range, Text:="= " & IntPart & " \*CHINESENUM2") MyField.Select '选定域(最后是用指定文本覆盖选定区域) '如果仅有角分情况下,Mychinese为"" MyChinese = VBA.IIf(MyField.Result <> "零", MyField.Result, "") .Text = Lable & MyChinese & Oddment Application.ScreenUpdating = True '恢复屏幕更新 End With Exit Sub ErrHandle: MsgBox "选定数据的绝对值不得超过2147483647!", vbOKOnly + vbExclamation, "Warning" End Sub '----------------------

york888 · 发表于 2005-3-24 10:29

守柔版主的大写金额宏, 经测试后我觉得更好用, 收藏! 多谢!

守柔 · 发表于 2007-2-14 17:54

应网友要求，加上了对于空格和千分位分隔符的识别。

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-2-14 17:51:50
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0156^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub GetChineseNum2()
'修正了原数据中含有千分位分隔符,并加入了空格容错,允许数字中带有空格
    Dim Numeric As Currency, IntPart As Long, DecimalPart As Byte, MyField As Field, Label As String
    Dim Jiao As Byte, Fen As Byte, Oddment As String, Odd As String, MyChinese As String
    Dim strNumber As String
    Const ZWDX As String = "壹贰叁肆伍陆柒捌玖零"    '定义一个中文大写汉字常量
    On Error Resume Next    '错误忽略
    With Selection
        strNumber = VBA.Replace(.Text, " ", "")
        Numeric = VBA.Round(VBA.CCur(strNumber), 2)    '四舍五入保留小数点后两位
        '判断是否在表格中
        If .Information(wdWithInTable) Then _
           .MoveRight unit:=wdCell Else .MoveRight unit:=wdCharacter
        '对数据进行判断,是否在指定的范围内
        If VBA.Abs(Numeric) > 2147483647 Then MsgBox "数值超过范围!", _
           vbOKOnly + vbExclamation, "Warning": Exit Sub

守柔 · 发表于 2007-2-14 17:55

        IntPart = Int(VBA.Abs(Numeric))    '定义一个正整数
        Odd = VBA.IIf(IntPart = 0, "", "圆")    '定义一个STRING变量
        '插入中文大写前的标签
        Label = VBA.IIf(Numeric = VBA.Abs(Numeric), "人民币金额大写:　", "人民币金额大写:　负")
        '对小数点后面二位数进行择定
        DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100
        Select Case DecimalPart
        Case Is = 0    '如果是0,即是选定的数据为整数
            Oddment = VBA.IIf(Odd = "", "", Odd & "整")
        Case Is < 10    '<10,即是零头是分
            Oddment = VBA.IIf(Odd <> "", "圆零" & VBA.Mid(ZWDX, DecimalPart, 1) & "分", _
                              VBA.Mid(ZWDX, DecimalPart, 1) & "分")
        Case 10, 20, 30, 40, 50, 60, 70, 80, 90    '如果是角整
            Oddment = "圆" & VBA.Mid(ZWDX, DecimalPart / 10, 1) & "角整"
        Case Else    '既有角,又有分的情况
            Jiao = VBA.Left(CStr(DecimalPart), 1)    '取得角面值
            Fen = VBA.Right(CStr(DecimalPart), 1)    '取得分面值
            Oddment = Odd & VBA.Mid(ZWDX, Jiao, 1) & "角"    '转换为角的中文大写
            Oddment = Oddment & VBA.Mid(ZWDX, Fen, 1) & "分"    '转换为分的中文大写
        End Select

守柔 · 发表于 2007-2-14 17:55

        '指定区域插入中文大写格式的域
        Set MyField = .Fields.Add(Range:=.Range, Text:="= " & IntPart & " \*CHINESENUM2")
        MyField.Select    '选定域(最后是用指定文本覆盖选定区域)
        '如果仅有角分情况下,Mychinese为""
        MyChinese = VBA.IIf(MyField.Result <> "零", MyField.Result, "")
        .Text = Label & MyChinese & Oddment
    End With
End Sub
'----------------------

fengeryan · 发表于 2007-3-11 10:23

学习,谢谢分享

hhzjxss · 发表于 2007-3-12 11:24

不错，word编程还没学呢！

[此贴子已经被作者于2007-3-12 11:24:35编辑过]

hhzjxss · 发表于 2007-3-12 11:30

守柔版主能够将修改后的传上来吗？

谢谢了！

		自动登录	找回密码
密码			免费注册

[分享]人民币金额大写

评分