能否让word中的小写金额，自动转换为大写金额

zxy_ok

在excel中可以通过公式，就可以让小写金额自动转换为大写金额。如：1234567.89，转换为壹佰贰拾叁万肆仟伍佰陆拾柒元捌角玖分。

请教诸位高人，能否有办法让word中的小写金额，也能自动转换为大写金额？

gwjkkkkk

Option Explicit
Sub test()
    Dim strRngText$
    With ActiveDocument.Tables(1)
        n = .Range.Cells.Count
        For i = 1 To n
            strRngText = Left(.Range.Cells(i).Range.Text, Len(.Range.Cells(i).Range.Text) - 2)
            If IsNumeric(strRngText) Then
                a = CCur(strRngText)
                .Range.Cells(i).Range.Text = numToChiCur(CCur(strRngText))
            End If
       Next i
    End With
End Sub

gwjkkkkk

请参考附件。。。

413191246se

楼主问有没有办法，回答是，有。办法就是用宏。

zxy_ok

完全实现预期要求，非常感谢“gwjkkkkk”的帮助！

zxy_ok

gwjkkkkk 发表于 2024-3-1 21:42
请参考附件。。。

继续请教，实际工作中，由于小写金额的单元格中，前面有人民币符号“¥”，结尾有“元”，不是单纯的数字。导致原来的宏不能正常使用。
我只会在excel中用字符串函数截取出其中的数字，但是不会在word中这样应用。所以请高手给再改进一下。

dongdonggege

我对Word不熟，刚才从网上现抄了一个，网址：https://baijiahao.baidu.com/s?id ... r=spider&for=pc。
Excel自定义函数，选择那组数据，运行

1. Sub test()
   
2.     Dim s As Double
   
3.     s = Selection.Range
   
4.     Debug.Print NumToChar(s)
   
5.     Selection.EndKey Unit:=wdLine
   
6.     Selection.TypeParagraph
   
7.     Selection.TypeText Text:=NumToChar(s)
   
8. End Sub
   
9. 
   
10. Function NumToChar(Number As Double) As String
    
11.     Dim strNum As String
    
12.     Dim arrNum(), arrChar(), arrUnits(), arr()
    
13.     Dim k As Integer
    
14.    
    
15.     Temp = Abs(Round(Number, 2)) * 100
    
16.     strNum = CStr(Temp)
    
17.     arrChar = Array("零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
    
18.     arrUnits = Array("分", "角", "元", "拾", "佰", "仟", "万", "拾", "佰", "仟", "亿", "拾", "佰", "仟", "兆", "拾", "佰", "仟", "京")
    
19.     For i = Len(strNum) To 1 Step -1
    
20.         ReDim Preserve arr(k)
    
21.         arr(k) = Mid(strNum, i, 1)
    
22.         If arr(k) = 0 Then
    
23.             If InStr("元万亿兆", arrUnits(k)) Then
    
24.                 arr(k) = arrUnits(k)
    
25.             Else
    
26.                 arr(k) = "零"
    
27.             End If
    
28.         Else
    
29.             arr(k) = arrChar(arr(k)) & arrUnits(k)
    
30.         End If
    
31.         k = k + 1
    
32.     Next
    
33.     strNum = ""
    
34.     For i = UBound(arr) To LBound(arr) Step -1
    
35.         strNum = strNum & arr(i)
    
36.     Next
    
37.     If Round(Number, 0) = Number Then
    
38.         strNum = Left(strNum, InStr(strNum, "元")) & "整"
    
39.     ElseIf Round(Number, 1) = Number Then
    
40.         strNum = Left(strNum, InStr(strNum, "角")) & "整"
    
41.     End If
    
42.    
    
43.     Do While InStr(strNum, "零零") > 0
    
44.         strNum = Replace(strNum, "零零", "零")
    
45.     Loop
    
46.    
    
47.     strNum = Replace(strNum, "零兆", "兆")
    
48.     strNum = Replace(strNum, "零亿", "亿")
    
49.     strNum = Replace(strNum, "零万", "万")
    
50.     strNum = Replace(strNum, "零元", "元")
    
51.     strNum = Replace(strNum, "兆亿", "兆")
    
52.     strNum = Replace(strNum, "兆万", "兆")
    
53.     strNum = Replace(strNum, "亿万", "亿")
    
54.     If Number < 0 Then
    
55.         strNum = "负" & strNum
    
56.     ElseIf Number = 0 Then
    
57.         strNum = "零元整"
    
58.     End If
    
59.     NumToChar = strNum
    
60. End Function
    

复制代码

你的数据1234567.89，运行正确。

dongdonggege

帖子等待审核，我再发一遍程序压缩文件，运行结果图。

dongdonggege

zxy_ok 发表于 2024-3-4 16:00
继续请教，实际工作中，由于小写金额的单元格中，前面有人民币符号“&#165;”，结尾有“元”，不是单 ...

选择需要的字符，比如前面有人民币符号，后面有元，先定义一个变量，Dim d As String,d = Selection.Range,再去读人民币符号，后面的元，d = Mid(d, 2, Len(d) - 2)。再把字符型转成双精度函数，Dim s As Double,s = CDbl(d)，再运行我的程序，后面的程序，我就是这样改的。

1. Sub test()
   
2.     Dim d As String
   
3.     d = Selection.Range
   
4.     d = Mid(d, 2, Len(d) - 2)
   
5.     Dim s As Double
   
6.     s = CDbl(d)
   
7.     'Debug.Print NumToChar(s)
   
8.     Selection.EndKey Unit:=wdLine
   
9.     Selection.TypeParagraph
   
10.     Selection.TypeText Text:=NumToChar(s)
    
11. End Sub

复制代码

NumToChar函数在前面的程序里。

gwjkkkkk

zxy_ok 发表于 2024-3-4 16:00
继续请教，实际工作中，由于小写金额的单元格中，前面有人民币符号“&#165;”，结尾有“元”，不是单 ...

套二个replace即可。。。