word文档自动设置千分位问题

sandorn

目的：将文档标为黄色的数值，自动以千分位形式展现。

下面是收集的两套代码，都有些问题，寻求帮助！

Sub 正则4千分位()

    On Error Resume Next

   Application.ScreenUpdating = False   '关闭屏幕更新,加快程序运行

    Dim myRange As Range,mt As Match, oRang As Range, n%, m%

   

    If Selection.Start<> Selection.End Then

        Set myRange =Selection.Range

    Else '无选择区

        Set myRange =ActiveDocument.Content '定义为主文档文字部分

    End If

   

    WithCreateObject("vbscript.regexp")

        .Pattern ="[0-9.]{4,}"  '正则表达式有些问题

        .Global = True:.IgnoreCase = False: .MultiLine = True

        For Each mt In.Execute(myRange.Text)

            m =mt.FirstIndex: n = mt.length

            Set oRang =ActiveDocument.Range(myRange.Start + m, myRange.Start + m + n)

            oRang.Text =VBA.Format(oRang.Text, "Standard") '修改格式

        Next

    End With

End Sub

Function GetRepeatedTimes(ByVal strParent As String, _

        ByVal strChild AsString) As Long

    Dim lngLenOfChild AsLong

   

    lngLenOfChild =Len(strChild)

   

    If lngLenOfChild Then

        GetRepeatedTimes= (Len(strParent) - Len(Replace(strParent, strChild, vbNullString))) /lngLenOfChild

    End If

End Function

Sub 千分位()

    '78085842(凯文)&1838095599(春天)@QQ群257182022（Word& VBA）

    '有些问题，会把年份都更改了

    On Error Resume Next

   Application.ScreenUpdating = False   '关闭屏幕更新,加快程序运行

    Dim Rng As Range,length%, End_selection&

   

    If Selection.Type =wdSelectionIP Then  'Selection.Start =Selection.End

        End_selection =ActiveDocument.Content.End

        Set Rng =ActiveDocument.Content '定义为主文档文字部分

    Else '有选择区

        End_selection =Selection.Range.End

        Set Rng =Selection.Range '定义为选中文字部分

    End If

   

    With Rng.Find

        .ClearFormatting

        .Text ="[.0-9]{4,}"    '查找数字

        .MatchWildcards =True

        

        Do While .Execute

            With .Parent

                If .Start> End_selection Then Exit Do

                If GetRepeatedTimes(.Text,".") > 1 Then Exit Do '数值有一个以上的小数点，则跳过

                length =Len(.Text)

                .Text =VBA.Format(VBA.Val(.Text), "Standard") '转为千分位格式

               End_selection = End_selection + Len(.Text) - length

                .Start =.End

            End With

        Loop

        

    End With

   

   Application.ScreenUpdating = True '恢复屏幕更新

End Sub

现将2019年度财务状况汇报如下：

2018年7月1日后入司员工发放奖金的50%。一位数1个，俩位数12件，三位数234元，招待费788.12元，房租4935元，办公费674539.00 元，本年实现100087.50 元，甲产品1234600.05元，剩余9776500.0116 元，利润-8324.032元。资产总额95.84元。最后结余0元。4133.897

18376	14133.897552	1484	-913
0.981	1.	.04842	0.1.2.3

413191246se

楼主，如果你下载试用我的《Word2003VBA通用模板宏（2019元旦版）》的话（即使是2007及以上版本也可以参考其中的代码），里面的《千分位》宏似乎能满足你的要求，下面是链接：
http://club.excelhome.net/thread-1452376-1-1.html

sandorn

413191246se 发表于 2019-1-8 23:18
楼主，如果你下载试用我的《Word2003VBA通用模板宏（2019元旦版）》的话（即使是2007及以上版本也可以参考 ...

感谢，我学习下！！

zmj9151

vba.format(str,"#,##0")

413191246se

谢谢 楼上 朋友！——我的《千分位》宏算了好久，才得到正确公式；而楼上朋友提供的代码仅一行代码，即解决问题，太好了！——经我实践，可以这样做：（假设选定了一串数字，不包括段落标记）
如果是整数：Selection.Text=VBA.Format(Selection.Text,"#,###")
如果是小数：Selection.Text=VBA.Format(Selection.Text,"#,###.##")
* 不知 楼上 朋友 对于 人民币中文大写金额 有什么一行代码没有？（如：34.57元，转换为大写）。

zmj9151

413191246se 发表于 2019-1-11 00:26
谢谢 楼上 朋友！——我的《千分位》宏算了好久，才得到正确公式；而楼上朋友提供的代码仅一行代码，即解决 ...

那个没有研究，这个千分位格式是微软设计的。

sandorn

修改完善了一下，find后format,正则基本放弃了，实在不会

1. Sub 千分位()
   
2.     '78085842(凯文)&1838095599(春天)@QQ群257182022（Word & VBA）
   
3.     On Error Resume Next
   
4.     Application.ScreenUpdating = False    '关闭屏幕更新,加快程序运行
   
5.     Dim Rng As Range, length%, End_selection&
   
6.    
   
7.     If Selection.Type = wdSelectionIP Then  'Selection.Start = Selection.End
   
8.         End_selection = ActiveDocument.Content.End
   
9.         Set Rng = ActiveDocument.Content '定义为主文档文字部分
   
10.     Else '有选择区
    
11.         End_selection = Selection.Range.End
    
12.         Set Rng = Selection.Range '定义为选中文字部分
    
13.     End If
    
14.    
    
15.     With Rng.Find
    
16.         .ClearFormatting
    
17.         .Text = "[.0-9]{4,}"    '查找数字
    
18.         .MatchWildcards = True
    
19.         
    
20.         Do While .Execute
    
21.             With .Parent
    
22.                 If .Start > End_selection Then Exit Do
    
23.                 If CountStr(.Text, "[\.]") > 1 Then Exit Do '数值有一个以上的小数点，则跳过
    
24.                 length = Len(.Text)
    
25.                 .Text = VBA.Format(VBA.Val(.Text), "Standard") '转为千分位格式
    
26.                 End_selection = End_selection + Len(.Text) - length
    
27.                 .Start = .End
    
28.             End With
    
29.         Loop
    
30.         
    
31.     End With
    
32.     '有些问题，会把年份都更改了。将修改的年份恢复（全文）
    
33.     ActiveDocument.Content.Find.Execute FindText:="(2),([0-9]{3}).00年", ReplaceWith:="\1\2年", Replace:=wdReplaceAll, MatchWildcards:=True
    
34.     Application.ScreenUpdating = True '恢复屏幕更新
    
35. End Sub

复制代码

jiangxiaoyun

Sub 设置千分位格式()
Dim myRange As Range, myValue As Double
Application.ScreenUpdating = False '关闭屏幕更新,加快程序运行
Do '进入一个循环
'定义myRange为活动文档的主文字部分
Set myRange = ActiveDocument.Content
With myRange.Find '查找设置
.ClearFormatting '清除格式
.Text = "[0-9]{4,}[!年]" '查找四个以上的数字且其后为不为年的内容
.MatchWildcards = True '使用通配符
If .Execute = False Then Exit Do '如果未找到则退出循环
myValue = Val(myRange.Text) '取得数字
myRange.SetRange myRange.Start, myRange.End - 1 '重新定义myRange对象
myRange.Text = VBA.Format$(myValue, "#,##0") '写入千分位格式
End With
Loop
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

jiangxiaoyun

http://www.exceltip.net/thread-25818-1-1.html

gaolzhen

sandorn 发表于 2019-1-11 13:26
修改完善了一下，find后format,正则基本放弃了，实在不会

可以用，不错