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

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

复制代码

sinc4233

413191246se 发表于 2020-5-19 00:35
* 楼主 的意思，正与我的猜想一致！请试试下面的代码：（请注意：粉红色是为了鲜明核对数据，如果不想要颜 ...

真的非常感谢楼主,结果差不多就是这样的.  再次感谢.

sinc4233

413191246se 发表于 2020-5-19 00:35
* 楼主 的意思，正与我的猜想一致！请试试下面的代码：（请注意：粉红色是为了鲜明核对数据，如果不想要颜 ...

楼主, 目前测试的时候出现了BUG. 就是有些改了,有些没改.不知道哪里的问题.

相约零八001

还没有用，希望好用！

lwm123138

楼主，我用的是office365 根据Word2007 快速访问工具栏说明，并没有找到Word.qat文件 ，不知道要怎么设置工具栏

413191246se

* lwm123138 朋友：Office2019 已经改了，快速访问工具栏-路径:
     C:\Users\lncyg\AppData\Local\Microsoft\Office\Word.officeUI
  Office365 也许与 Office2019 相同！就是快速访问工具栏已经不再保存在 Word.qat 中，而是保存在 Word.officeUI 中，找到并删除此文件也可以，可直接在 Word 中对不喜欢的按钮删除、对喜欢的按钮添加即可；当然如果找到此文件，可以在使用一段时间后将其备份。

* sinc4233 朋友：你说的“有些改了，有些未改”什么意思？改了的是因为前面有“金额大写：”这5个字符，没改的当然是前面没有“金额大写：”这5个字符。如果你认为仍然不对，请将附件传上来，或粘贴到帖子中也可。

sinc4233

sinc4233 发表于 2020-5-19 11:01
楼主, 目前测试的时候出现了BUG. 就是有些改了,有些没改.不知道哪里的问题.

目前发现出现BUG的是WPS版本, 会有个别不会替换掉, 我自己的office还没发现,不知道是哪里的原因.

413191246se

不建议使用 WPS，因为要想玩 VBA，还是 Office 稳妥。

413191246se

* 对付一般小文章，可以试试本人的宏代码，F8 公文排版，F7 普通排版，一键自动排版，速度极快。

413191246se

各位朋友，以往的旧帖，请不要观看和下载了，本帖是目前最新版本，请下载本帖的压缩包。