Word2003 & 2007 VBA 通用模板宏(2020元旦版) 2019-10-17

413191246se

***2003版本请用2003代码，2007版本以上的请用2007代码，但最好是删除找到的 Word 空白通用模板 Normal.dot（2003版本）或 Normal.dotm（2007以上版本）文件后应用，这样才是全新的。

bgrind

谢谢大神的慷慨分享！

413191246se

顶一下。。。

413191246se

再顶一下……如果哪位朋友，在使用 Word2003/2007 的过程中，要简单地进行一下公文排版和普通格式排版，可以用我的这个《通用模板宏》，也叫《自动排版宏》，详细情况请参见其中 Readme.

413191246se

顶一下。。。。。。

sinc4233

你好.今天无意间看到你18年的一个帖子回复.word里人民币转大写的问题.方便加个QQ吗. 我没学过代码.目前只改了一小部分自己想要的结果.还有一部分实现不了

sinc4233

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

复制代码

楼主你好 , 今天翻了半天找到你的这个代码.还可以用.就是和我想要的结果还有点不一样,由于不懂代码.改了半天只实现一点点自己想要的结果.麻烦楼主帮忙改下吗?
如果自己选中数字后,替换的结果不要原数字+ 元 + 大写, 只要大写的结果就可以了.然后全文替换的时候只改 "金额大写:"  后面的数字.    麻烦楼主方便的时候帮忙改下.非常感谢.

代码原结果:



想要的结果:

413191246se

sinc4233 朋友，你好！——我最新版本《人民币中文大写》宏程序，只支持全文将小写金额（数字元）转换为中文大写，不支持单个选定。我想一般日常工作中也不会有一组金额吧，还是要全文的金额都要转换。是不是呢？请提供一下日常工作中真实的金额小写转大写的文本附件。

sinc4233

413191246se 发表于 2020-5-17 01:17
sinc4233 朋友，你好！——我最新版本《人民币中文大写》宏程序，只支持全文将小写金额（数字元）转换为中 ...

楼主,你好 .  我的意思是全文所有  "金额大写:"  后面的数字转成大写.. 不知道为什么无法上传附件,只能粘贴一部分内容,.麻烦楼主再看下.谢谢楼主.

关于《建东部建设投资有限公司2019年资产收益权一期六期第三次付息通知》，客户本金：2000000元，客户利息：87388.77元，需要支付利息：87388.77元。金额大写：87388.77。请贵司于2020年06月25日前支付至客户收益账户内。

关于《建东部建设投资有限公司2019年资产收益权一期七期第三次付息通知》，客户本金：6200000元，客户利息283,324.11元，需要支付利息：283,324.11元。金额大写：283,324.11。请贵司于2020年06月25日前支付至客户收益账户内。

关于《建东部建设投资有限公司2019年资产收益权一期八期第三次付息通知》，客户本金：2760000元，客户利息：123,096.33元，需要支付利息：：123,096.33元。金额大写：123,096.33。请贵司于2020年06月25日前支付至客户收益账户内。

413191246se

* 楼主 的意思，正与我的猜想一致！请试试下面的代码：（请注意：粉红色是为了鲜明核对数据，如果不想要颜色，可以将代码倒数第8行含有“粉红”一行代码删除或屏蔽）

1. Sub 人民币中文大写_金额大写()
   
2. 
   
3.     ActiveDocument.Content.Find.Execute "金额大写:", , , 1, , , , , , "金额大写：", 2
   
4. 
   
5.     Const s As String = "万仟佰拾亿仟佰拾万仟佰拾元角分"
   
6. 
   
7.     Dim c&, i$, j&, a$, n&
   
8. 
   
9.     c = 0
   
10. 
    
11.     With ActiveDocument.Content.Find
    
12.         .ClearFormatting
    
13.         .Text = "金额大写：[0-9. 　^s^t,，]{1,}"
    
14.         .Forward = True
    
15.         .MatchWildcards = True
    
16.         Do While .Execute
    
17.             With .Parent
    
18.                 .MoveStart 1, 5
    
19. 
    
20.                 i = .Text
    
21. 
    
22.                 i = Replace(i, " ", "")
    
23.                 i = Replace(i, "　", "")
    
24.                 i = Replace(i, vbTab, "")
    
25.                 i = Replace(i, ChrW(160), "")
    
26.                 i = Replace(i, ",", "")
    
27.                 i = Replace(i, "，", "")
    
28. 
    
29.                 If i Like "*.*.*" Then .Font.Color = wdColorRed: GoTo sk
    
30. 
    
31.                 i = Format(i, "Standard")
    
32.                 i = Replace(i, ",", "")
    
33.                 i = Replace(i, ".", "")
    
34. 
    
35.                 j = Len(i)
    
36. 
    
37.                 If j > 15 Then GoTo sk
    
38. 
    
39.                 a = ""
    
40. 
    
41.                 For n = 1 To j
    
42.                     a = a & Mid(i, n, 1) & Mid(s, 15 - j + n, 1)
    
43.                 Next n
    
44. 
    
45.                 a = Replace(a, "1", "壹")
    
46.                 a = Replace(a, "2", "贰")
    
47.                 a = Replace(a, "3", "叁")
    
48.                 a = Replace(a, "4", "肆")
    
49.                 a = Replace(a, "5", "伍")
    
50.                 a = Replace(a, "6", "陆")
    
51.                 a = Replace(a, "7", "柒")
    
52.                 a = Replace(a, "8", "捌")
    
53.                 a = Replace(a, "9", "玖")
    
54.                 a = Replace(a, "0", "零")
    
55. '''
    
56.                 a = Replace(a, "零仟", "零")
    
57.                 a = Replace(a, "零佰", "零")
    
58.                 a = Replace(a, "零拾", "零")
    
59. 
    
60.                 Do While a Like "*零零*"
    
61.                     a = Replace(a, "零零", "零")
    
62.                 Loop
    
63. 
    
64.                 a = Replace(a, "零亿", "亿零")
    
65.                 a = Replace(a, "零万", "万零")
    
66.                 a = Replace(a, "零元", "元零")
    
67. 
    
68.                 Do While a Like "*零零*"
    
69.                     a = Replace(a, "零零", "零")
    
70.                 Loop
    
71. 
    
72.                 a = Replace(a, "零角零分", "整")
    
73.                 a = Replace(a, "零角", "零")
    
74.                 a = Replace(a, "零分", "")
    
75. 
    
76.                 If a Like "元零*" Then a = Replace(a, "元零", "")
    
77.                 If a = "元整" Then a = "零" & a
    
78. 
    
79.                 If a Like "*万零元*" And Val(a) < 100000000 Then a = Replace(a, "万零元", "万元") '10万<=X<1亿
    
80.                 a = Replace(a, "亿万", "亿")
    
81. 
    
82.                 If a Like "*亿零万*" Then a = Replace(a, "零万", "") '>=10亿
    
83. '''
    
84.                 If c = 1 Then
    
85.                     .InsertBefore Text:="（人民币" & a & "）"
    
86.                 Else
    
87.                     .Delete
    
88.                     .InsertAfter Text:=a
    
89.                     .Font.Color = wdColorPink '粉红（本行代码可删除/屏蔽）
    
90.                 End If
    
91. sk:
    
92.                 .Start = .End
    
93.             End With
    
94.         Loop
    
95.     End With
    
96. End Sub

复制代码