给word中的数字添加千分位符号

1024kb

下午用word 2003干活，碰到给大量数字添加千分符的问题，搜了守柔的老帖子http://club.excelhome.net/forum.php?mod=viewthread&tid=65559，除了几张图片和word文档之外什么也没看到，只好自己动手丰衣足食，写了一个宏。没学过VB，完全现学现卖，欢迎批评指正。也不知道这个陈芝麻烂谷子的问题是不是早有人轻松解决了，权当玩玩吧。
除了4位数（及以上，有可能用到公元10000年吗？呵呵）的年份和三位以上的小数也会被分隔之外，其它都没有什么问题，表格中的数字也没问题。
使用了键盘左上角Esc下面的“`”作为终止标志符号，如果原文中包含该符号，可暂时替换为其他的。

Sub InsertThousandSplitSymbol()
'年份、小数也将被分隔，运行完毕之后应注意纠正。小数一般最多保留至小数点后两位，不会有太大影响；年份则通常有较为明显的特征，可以统一替换。
    Selection.HomeKey Unit:=wdStory
    Selection.TypeText Text:="`000 "
    Selection.EndKey Unit:=wdStory
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^#^#^#"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.MoveLeft Unit:=wdCharacter, Count:=2
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Do Until Selection = "`"
    If Asc(Selection) > 47 And Asc(Selection) < 58 Then
        If Len(Selection) = 1 Then
        Selection.MoveRight Unit:=wdCharacter, Count:=1
        Selection.TypeText Text:=","
        Else
        Selection.EndKey Unit:=wdLine
        End If
    Else
    End If
    Application.Browser.Previous
    Selection.MoveLeft Unit:=wdCharacter, Count:=2
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Loop
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "`000 "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

1024kb

早上起来想了想，现在的方法是搜索3位连续的数字，搜索4位才更合理，也更简单，修改了一下。不过没系统地看过VB命令，没找到搜索至文首即退出循环的好方法，仍然采用了临时添加终止符号的方式，看起来麻烦了不少，请多指教。

Sub InsertThousandSplitSymbol()
'年份、小数也将被分隔，运行完毕之后应注意纠正。小数一般最多保留至小数点后两位，不会有影响；年份则通常有较为明显的特征，可以统一替换。
   Selection.HomeKey Unit:=wdStory
    Selection.TypeText Text:="`0000 "'在文档开始临时添加终止标识符。
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^#^#^#^#"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.EndKey Unit:=wdStory'执行一次连续四位数字的搜索，并跳到文末，准备进入正题。
Do Until Selection = "`"
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Application.Browser.Previous'没有遇到终止符则跳至刚添加的分隔符左侧，继续查找左侧的连续四位数字。
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:=","'添加分隔符。
    Selection.MoveLeft Unit:=wdCharacter, Count:=3
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend'选择已处理过的四位数左侧的字符，以检查是否遇到终止符。
Loop
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "`0,000 "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll'删除临时符号。
End Sub

qigengzier

好贴 占位收藏

qingliang_yan

好用，像我的这种99999（1111-99999）这样的就只能通过这个vba了，必须顶起来！