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

413191246se · 发表于 2018-12-30 23:36

Sub 人民币中文大写()
'功能：全文查找数字元（也可单选数字）转换为人民币中文大写
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
x = MsgBox("大写是否放在数字前面？（否则后面）", vbYesNoCancel + vbExclamation, "人民币中文大写")
If x = vbYes Then
n = 1
ElseIf x = vbNo Then
n = 0
Else
End
End If
'全文/单个
If Selection.Type <> wdSelectionIP Then
Do While Selection.Characters.First Like "[!0-9０-９]"
Selection.MoveStart unit:=wdCharacter, Count:=1
Loop
Do While Not (Selection.Characters.Last Like "[0-9０-９.,，　]" Or Selection.Characters.Last Like ChrW(160))
Selection.MoveEnd unit:=wdCharacter, Count:=-1
Loop
Selection.MoveEnd unit:=wdCharacter, Count:=1
If Selection Like "*[!元]" Then
Selection.MoveEnd unit:=wdCharacter, Count:=-1
Selection.InsertAfter Text:="元"
End If
s = 1
GoTo SingleNum
End If
'全文查找数字元
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Do While Selection.Find.Execute(findtext:="^#", Forward:=True, MatchWildcards:=False)
Do While Selection.Characters.Last Like "[0-9０-９.,，　]" Or Selection.Characters.Last Like ChrW(160)
Selection.MoveEnd unit:=wdCharacter, Count:=1
Loop
SingleNum:
If Selection Like "*元" Then
'格式处理
Selection.Font.Bold = True '加粗
Selection.Font.Color = wdColorBlue '蓝色
Selection.Font.Underline = wdUnderlineWavyHeavy '重波浪线
'选定数字
Selection.MoveEnd unit:=wdCharacter, Count:=-1
k = "万仟佰拾亿仟佰拾万仟佰拾元空角分"
i = Selection
'规范数字
i = Replace(i, ChrW(160), "") '替换不间断空格
i = Replace(i, " ", "") '替换半角空格
i = Replace(i, "　", "") '替换全角空格
i = Replace(i, ",", "") '替换英文逗号
i = Replace(i, "，", "") '替换中文逗号
i = Format(i) '删除数字前后无效零/小数点
'单个数字
If s = 1 Then
i = StrConv(i, vbNarrow) '全角转半角
Dim a
a = Val(i) '数值型
If Len(i) <> Len(a) Then MsgBox "非纯数字，无法转换！！！", vbOKOnly + vbCritical, "人民币中文大写": End
End If
If i Like ".*" Then i = "0" & i
'错误报警
If Selection Like "*.*.*" Or Val(i) > 999999999999.99 Then
Selection.Font.Color = wdColorRed '红色
Selection.Font.Underline = wdUnderlineWavyHeavy '重波浪线
GoTo Skip
End If
'强制格式
If i Like "*?.??" Then
ElseIf i Like "*?.?" Then
i = i & "0"
ElseIf i Like "*?.???*" Then
i = Format(i, "0.00")
Else
i = i & ".00"
End If
'核心代码
v = Len(i)
k = Right(k, v)
u = 0
y = ""
Do
u = u + 1
j = Mid(i, u, 1) & Mid(k, u, 1)
y = y & j
Loop Until u = v
i = y
'基本替换
i = Replace(i, "1", "壹")
i = Replace(i, "2", "贰")
i = Replace(i, "3", "叁")
i = Replace(i, "4", "肆")
i = Replace(i, "5", "伍")
i = Replace(i, "6", "陆")
i = Replace(i, "7", "柒")
i = Replace(i, "8", "捌")
i = Replace(i, "9", "玖")
i = Replace(i, "0", "零")
i = Replace(i, ".", "点")
i = Replace(i, "点空", "")
'零字替换
i = Replace(i, "零仟", "零")
i = Replace(i, "零佰", "零")
i = Replace(i, "零拾", "零")
Do While i Like "*零零*"
i = Replace(i, "零零", "零")
Loop
i = Replace(i, "零亿", "亿零")
i = Replace(i, "零万", "万零")
i = Replace(i, "零元", "元零")
Do While i Like "*零零*"
i = Replace(i, "零零", "零")
Loop
i = Replace(i, "零角零分", "整")
i = Replace(i, "零角", "零")
i = Replace(i, "零分", "")
If i Like "元零*" Then i = Replace(i, "元零", "")
If i = "元整" Then i = "零" & i
If i Like "*万零元*" And Val(i) < 100000000 Then i = Replace(i, "万零元", "万元") '10万<=X<1亿
i = Replace(i, "亿万", "亿")
If i Like "*亿零万*" Then i = Replace(i, "零万", "") '>=10亿
'转换结果
i = "（人民币" & i & "）"
If n = 1 Then Selection.InsertBefore Text:=i Else Selection.MoveEnd unit:=wdCharacter, Count:=1: Selection.InsertAfter Text:=i
If s = 1 Then End
End If
Skip:
Selection.MoveRight unit:=wdCharacter, Count:=1
Loop
End Sub

复制代码

Limpo · 发表于 2019-5-17 09:37

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

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

{ 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 · 发表于 2019-5-21 11:29

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

muziligao · 发表于 2019-5-21 17:08

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

413191246se · 发表于 2019-5-21 23:51

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

muziligao · 发表于 2019-5-22 09:21

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

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

muziligao · 发表于 2019-5-22 09:34

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

413191246se · 发表于 2019-5-22 15:28

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

muziligao · 发表于 2019-5-22 21:45

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

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

灭日传说 · 发表于 2019-9-3 17:38

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

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