[分享并请测试]千分位代码新作

守柔

Option Explicit
Sub StandardNumber()
'本代码旨在解决WORD中数据转化为千分位
'数据限定要求:-922,337,203,685,477.5808 到 922,337,203,685,477.5807
'转化结果1000以上数据以千分位计算,小数点右侧保留二位小数;1000以下数据不变
Dim myRange As Range, i As Byte, myValue As Currency
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
NextFind: Set myRange = ActiveDocument.Content '定义为主文档文字部分
With myRange.Find '查找
.ClearFormatting '清除格式
.Text = "[0-9]{4,15}" '4到15位数据
.MatchWildcards = True '使用通配符
Do While .Execute '每次查找成功
i = 2 '起始值为2
'如果是有小数点
If myRange.Next(wdCharacter, 1) = "." Then
'进行一个未知循环
While myRange.Next(wdCharacter, i) Like "#"
i = i + 1 '只要是[0-9]任意数字则累加
Wend
'重新定义RANGE对象
myRange.SetRange myRange.Start, myRange.End + i - 1
End If
myValue = VBA.Val(myRange) '保险起见转换为数据,也可省略
myRange = VBA.Format(myValue, "Standard") '转为千分位格式
GoTo NextFind '转到指定行
Loop
End With
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
相关链接：

http://club.excelhome.net/dispbbs.asp?boardid=23&star=1&replyid=348597&id=65559&skin=0&page=1

konggs

坐沙发，老大的就是利害。[em17]

konggs

小弟也糊做了一个：请老大指点！

Sub 孤独二叶()
Dim MyRange
Dim FindChar As String, RepChar As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
FindChar = "([0-9])([0-9]{3}[!0-9])"
RepChar = "\1,\2"
With ActiveDocument.Content.Find '此处针对全文档
.ClearFormatting '清除格式
.MatchWildcards = True
Do While .Execute(findtext:=FindChar) = True '如果发现
.Execute findtext:=FindChar, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll
Loop
If .Execute(findtext:=FindChar) = False Then
Exit Sub
End If
End With
Application.ScreenUpdating = False '开启屏幕更新
End Sub

[此贴子已经被作者于2005-12-4 16:42:09编辑过]

gues1688

谢谢守柔老师，又学到了好多代码。

反复思考，试着学习做一个，好像会重复查找一次，一时还没想到解决办法：

Option Explicit
Sub StandardNumber1()
Dim myRange As Range
Application.ScreenUpdating = False
On Error Resume Next
Set myRange = Word.ActiveDocument.Content
With myRange.Find
.ClearFormatting
.Text = "[1-9][0-9]{1,14}[.0-9][0-9]{1,4}"
.MatchWildcards = True
Do While .Execute
myRange.Text = Format(myRange.Text, "###,###,###,###,###,###,###.####")
Loop
End With
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2005-12-4 17:28:56编辑过]

gues1688

以下是引用konggs在2005-12-4 16:21:16的发言：

小弟也糊做了一个：请老大指点！

Sub 孤独二叶()
Dim MyRange
Dim FindChar As String, RepChar As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
FindChar = "([0-9])([0-9]{3}[!0-9])"
RepChar = "\1,\2"
With ActiveDocument.Content.Find '此处针对全文档
.ClearFormatting '清除格式
.MatchWildcards = True
Do While .Execute(findtext:=FindChar) = True '如果发现
.Execute findtext:=FindChar, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll
Loop
If .Execute(findtext:=FindChar) = False Then
Exit Sub
End If
End With
Application.ScreenUpdating = False '开启屏幕更新
End Sub

妙！

不过，好像多位小数时，会有点小问题

konggs

加一个判断小数点的（仅仅加了一个判断条件）（但仍然没有老大的漂亮！）

Sub 孤独三叶()
Dim MyRange
Dim FindChar As String, RepChar As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
FindChar = "([!.][0-9])([0-9]{3}[!0-9])"
RepChar = "\1,\2"
With ActiveDocument.Content.Find '此处针对全文档
.ClearFormatting '清除格式
.MatchWildcards = True
Do While .Execute(findtext:=FindChar) = True '如果发现
.Execute findtext:=FindChar, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll
Loop
If .Execute(findtext:=FindChar) = False Then
Exit Sub
End If
End With
Application.ScreenUpdating = False '开启屏幕更新
End Sub

gues1688

以下是引用konggs在2005-12-4 18:27:27的发言：

加一个判断小数点的（仅仅加了一个判断条件）（但仍然没有老大的漂亮！）

Sub 孤独三叶()
Dim MyRange
Dim FindChar As String, RepChar As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
FindChar = "([!.][0-9])([0-9]{3}[!0-9])"
RepChar = "\1,\2"
With ActiveDocument.Content.Find '此处针对全文档
.ClearFormatting '清除格式
.MatchWildcards = True
Do While .Execute(findtext:=FindChar) = True '如果发现
.Execute findtext:=FindChar, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll
Loop
If .Execute(findtext:=FindChar) = False Then
Exit Sub
End If
End With
Application.ScreenUpdating = False '开启屏幕更新
End Sub

厉害，小数点的问题解决了，好像这样的数字还没处理好：2337203685470.5807

konggs

再来一个，不过不能放在一开头。否也不行。

Sub 孤独四叶()
Dim MyRange
Dim FindChar As String, findchar1 As String, RepChar As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
FindChar = "([!.][0-9])([0-9]{3}[!0-9])"
findchar1 = "([!.][0-9])([0-9]{3}"
RepChar = "\1,\2"
With ActiveDocument.Content.Find '此处针对全文档
.ClearFormatting '清除格式
.MatchWildcards = True
Do While .Execute(findtext:=FindChar) = True '如果发现
.Execute findtext:=FindChar, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll
Loop
If .Execute(findtext:=FindChar) = False Then
GoTo gn:
End If
gn: .Execute findtext:=findchar1, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll
End With
Application.ScreenUpdating = False '开启屏幕更新
End Sub

[此贴子已经被作者于2005-12-4 18:59:02编辑过]

ssq1109

现在对数字串国际国内的规范要求已不是用“,”分隔，而是用半角空格分隔（当然这点在代码中很好改），这从学生用的规范教材和国外出版的书籍上可得到证实。科技版面很多诸如下要求：

0.12345 --> 0.123 45

0.0012 --> 0.001 2

1110.0012 --> 1 110.001 2

即以小数点为中心，左右两边都是三位分一节。

再者像：

1997年

1900—2006年（或1900-2006年）

这样的年代数字在文档中又不允许分节。

上面几个代码我都测试过，好像都不能完全达到以上要求。

konggs

请再作测试：

Sub 孤独一叶()
Dim a%, fcount%, i%, replace0 As String
Dim find0 As String, find1 As String, find2 As String
Dim find4 As String, find3 As String, find5 As String
Application.ScreenUpdating = False
Debug.Print Timer
With ActiveDocument.Content.Find
find0 = "([0-9])([0-9]{3}.)"
find1 = "(.[0-9]{3})([0-9])"
find2 = "([0-9])([0-9]{3}[ ])"
find3 = "([ ])([0-9]{3})([0-9])"
find4 = "([0-9])([0-9]{3})([!0-9])"
find5 = "( )([0-9]{3})([-—年])"
replace0 = "\1 \2"
.MatchWildcards = True
For a = 0 To 5
Select Case a
Case 0
.Execute findtext:=find0, replacewith:=replace0, Replace:=wdReplaceAll

Case 1
.Execute findtext:=find1, replacewith:=replace0, Replace:=wdReplaceAll

Case 2
Do While .Execute(findtext:=find2) = True '如果发现
.Execute findtext:=find2, replacewith:=replace0, Replace:=wdReplaceAll
Loop

Case 3
Do While .Execute(findtext:=find3) = True '如果发现
.Execute findtext:=find3, replacewith:="\1\2 \3", Replace:=wdReplaceAll
Loop
Case 4
Do While .Execute(findtext:=find4) = True '如果发现
.Execute findtext:=find4, replacewith:="\1 \2\3", Replace:=wdReplaceAll
Loop
Case 5
Do While .Execute(findtext:=find5) = True '如果发现
.Execute findtext:=find5, replacewith:="\2\3", Replace:=wdReplaceAll
Loop
End Select
Next
End With
Application.ScreenUpdating = True
Debug.Print Timer

End Sub