[原创]使用域自动填充功能完成人民币金额大写

413191246se

1. Sub 人民币中文大写()
   
2. '功能：全文查找数字元（也可单选数字）转换为人民币中文大写
   
3. 
   
4.     Dim i As String, j As String, k As String, x As String, y As String, u As Long, v As Long, n As Long, s As Long
   
5.     x = MsgBox("大写是否放在数字前面？（否则后面）", vbYesNoCancel + vbExclamation, "人民币中文大写")
   
6.     If x = vbYes Then
   
7.         n = 1
   
8.     ElseIf x = vbNo Then
   
9.         n = 0
   
10.     Else
    
11.         End
    
12.     End If
    
13. 
    
14. '全文/单个
    
15.     If Selection.Type <> wdSelectionIP Then
    
16.         Do While Selection.Characters.First Like "[!0-9０-９]"
    
17.             Selection.MoveStart unit:=wdCharacter, Count:=1
    
18.         Loop
    
19.         Do While Not (Selection.Characters.Last Like "[0-9０-９.,， 　]" Or Selection.Characters.Last Like ChrW(160))
    
20.             Selection.MoveEnd unit:=wdCharacter, Count:=-1
    
21.         Loop
    
22.         Selection.MoveEnd unit:=wdCharacter, Count:=1
    
23.         If Selection Like "*[!元]" Then
    
24.             Selection.MoveEnd unit:=wdCharacter, Count:=-1
    
25.             Selection.InsertAfter Text:="元"
    
26.         End If
    
27.         s = 1
    
28.         GoTo SingleNum
    
29.     End If
    
30. 
    
31. '全文查找数字元
    
32.     Selection.HomeKey unit:=wdStory
    
33.     Selection.Find.ClearFormatting
    
34.     Do While Selection.Find.Execute(findtext:="^#", Forward:=True, MatchWildcards:=False)
    
35.         Do While Selection.Characters.Last Like "[0-9０-９.,， 　]" Or Selection.Characters.Last Like ChrW(160)
    
36.             Selection.MoveEnd unit:=wdCharacter, Count:=1
    
37.         Loop
    
38. SingleNum:
    
39.         If Selection Like "*元" Then
    
40.             '格式处理
    
41.             Selection.Font.Bold = True '加粗
    
42.             Selection.Font.Color = wdColorBlue '蓝色
    
43.             Selection.Font.Underline = wdUnderlineWavyHeavy '重波浪线
    
44. 
    
45.             '选定数字
    
46.             Selection.MoveEnd unit:=wdCharacter, Count:=-1
    
47.             k = "万仟佰拾亿仟佰拾万仟佰拾元空角分"
    
48.             i = Selection
    
49. 
    
50.             '规范数字
    
51.             i = Replace(i, ChrW(160), "") '替换不间断空格
    
52.             i = Replace(i, " ", "") '替换半角空格
    
53.             i = Replace(i, "　", "") '替换全角空格
    
54.             i = Replace(i, ",", "") '替换英文逗号
    
55.             i = Replace(i, "，", "") '替换中文逗号
    
56.             i = Format(i) '删除数字前后无效零/小数点
    
57. 
    
58.             '单个数字
    
59.             If s = 1 Then
    
60.                 i = StrConv(i, vbNarrow) '全角转半角
    
61.                 Dim a
    
62.                 a = Val(i) '数值型
    
63.                 If Len(i) <> Len(a) Then MsgBox "非纯数字，无法转换！！！", vbOKOnly + vbCritical, "人民币中文大写": End
    
64.             End If
    
65. 
    
66.             If i Like ".*" Then i = "0" & i
    
67. 
    
68.             '错误报警
    
69.             If Selection Like "*.*.*" Or Val(i) > 999999999999.99 Then
    
70.                 Selection.Font.Color = wdColorRed '红色
    
71.                 Selection.Font.Underline = wdUnderlineWavyHeavy '重波浪线
    
72.                 GoTo Skip
    
73.             End If
    
74. 
    
75.             '强制格式
    
76.             If i Like "*?.??" Then
    
77.             ElseIf i Like "*?.?" Then
    
78.                 i = i & "0"
    
79.             ElseIf i Like "*?.???*" Then
    
80.                 i = Format(i, "0.00")
    
81.             Else
    
82.                 i = i & ".00"
    
83.             End If
    
84. 
    
85.             '核心代码
    
86.             v = Len(i)
    
87.             k = Right(k, v)
    
88.             u = 0
    
89.             y = ""
    
90.             Do
    
91.                 u = u + 1
    
92.                 j = Mid(i, u, 1) & Mid(k, u, 1)
    
93.                 y = y & j
    
94.             Loop Until u = v
    
95.             i = y
    
96. 
    
97.             '基本替换
    
98.             i = Replace(i, "1", "壹")
    
99.             i = Replace(i, "2", "贰")
    
100.             i = Replace(i, "3", "叁")
     
101.             i = Replace(i, "4", "肆")
     
102.             i = Replace(i, "5", "伍")
     
103.             i = Replace(i, "6", "陆")
     
104.             i = Replace(i, "7", "柒")
     
105.             i = Replace(i, "8", "捌")
     
106.             i = Replace(i, "9", "玖")
     
107.             i = Replace(i, "0", "零")
     
108.             i = Replace(i, ".", "点")
     
109.             i = Replace(i, "点空", "")
     
110. 
     
111.             '零字替换
     
112.             i = Replace(i, "零仟", "零")
     
113.             i = Replace(i, "零佰", "零")
     
114.             i = Replace(i, "零拾", "零")
     
115. 
     
116.             Do While i Like "*零零*"
     
117.                 i = Replace(i, "零零", "零")
     
118.             Loop
     
119. 
     
120.             i = Replace(i, "零亿", "亿零")
     
121.             i = Replace(i, "零万", "万零")
     
122.             i = Replace(i, "零元", "元零")
     
123. 
     
124.             Do While i Like "*零零*"
     
125.                 i = Replace(i, "零零", "零")
     
126.             Loop
     
127. 
     
128.             i = Replace(i, "零角零分", "整")
     
129.             i = Replace(i, "零角", "零")
     
130.             i = Replace(i, "零分", "")
     
131. 
     
132.             If i Like "元零*" Then i = Replace(i, "元零", "")
     
133.             If i = "元整" Then i = "零" & i
     
134. 
     
135.             If i Like "*万零元*" And Val(i) < 100000000 Then i = Replace(i, "万零元", "万元") '10万<=X<1亿
     
136.             i = Replace(i, "亿万", "亿")
     
137. 
     
138.             If i Like "*亿零万*" Then i = Replace(i, "零万", "") '>=10亿
     
139. 
     
140.             '转换结果
     
141.             i = "（人民币" & i & "）"
     
142.             If n = 1 Then Selection.InsertBefore Text:=i Else Selection.MoveEnd unit:=wdCharacter, Count:=1: Selection.InsertAfter Text:=i
     
143.             If s = 1 Then End
     
144.         End If
     
145. Skip:
     
146.         Selection.MoveRight unit:=wdCharacter, Count:=1
     
147.     Loop
     
148. End Sub

复制代码

Limpo

Limpo 发表于 2017-6-20 22:34
十一年过去了，找到的答案依然是这个最强的
不知道现在新版的Word中是不是有了更简单的原生解决方案
我是 ...

又过了两年想起这件事来了，试着这么该了下代码貌似可以了：

1. { SET Data { ={ MERGEFIELD "金额" } } }{ SET JinE { =ABS(Data) \#"0.00" } }{ SET Yuan { =INT(JinE) } }{ SET Jiao { =INT(JinE*10-Yuan*10) } }{ SET Fen { =INT(JinE*100-Yuan*100-Jiao*10) } }{ IF Data < 0 "负" "" }{ IF Yuan = JinE "{ =Yuan \*CHINESENUM2 }圆整" { IF Fen = 0 "{ =Yuan \*CHINESENUM2 }圆{ =Jiao \*CHINESENUM2 }角整" { IF Jiao = 0 "{ =Yuan \*CHINESENUM2 }圆{ =Fen \*CHINESENUM2 }分" "{ =Yuan \*CHINESENUM2 }圆{ =Jiao \*CHINESENUM2 }角{ =Fen \*CHINESENUM2 }分" }} }

复制代码

发现另外一个问题，38000.02，这个金额的贰分显示为壹分。

muziligao

请问各位，在邮件合并中。具体该如何用。
楼主的域代码放在什么地方？

muziligao

请楼主指点一下，该如何实际运用。即，如果我是邮件合并，这段代码放在什么地方呢？谢谢

413191246se

楼上朋友：楼主是 守柔版主，他不是经常在线的。如果想用代码，可以试用我 91 楼的代码，放在通用模板 Normal.dot 中即可（先录制一个宏 Macro1，找到它，发现它是在 Normal.dot 中）。

muziligao

413191246se 发表于 2019-5-21 23:51
楼上朋友：楼主是 守柔版主，他不是经常在线的。如果想用代码，可以试用我 91 楼的代码，放在通用模板 Norm ...

由于我是在邮件合并中使用。请问下，如果用您的宏，会不会把整个文档的数字都搞成了大写。另外，支不支持上千万的数字。即12345678元。

muziligao

版主，我下载你的附件打开后，试了一下，当金额大于百万以后，就提示：错误!不能以指定格式显示编号。圆捌角捌分

413191246se

楼上朋友：我的《人民币中文大写》宏，会将文档中所有“数字元”（比如 345.67元）转为人民币中文大写，数字后面没有“元”字的不会有变化；但原数字元并不会改变。如果不放心，你可以打几个数字试试看！

muziligao

413191246se 发表于 2019-5-22 15:28
楼上朋友：我的《人民币中文大写》宏，会将文档中所有“数字元”（比如 345.67元）转为人民币中文大写，数 ...

直好意思 ，不会用宏。没整明白。让你费心了。

灭日传说

萌新完全不会用。。。只能佩服佩服