非常任务，筛选Word可识别词语——Word循环再快些！

wjhere

拜读了守柔版主大作“拼音居士”，高山仰止。就想做一些模仿。这篇帖子主要就是从一般的词语库中筛选Word可以识别的词语的。简单的说就是有的词语在Word中被认为是一个词语，如 阿波罗 ，有的词语被识别为多个词语，如 一字之差 我们做的就是从成万个词语中筛选出符合前一种情况的词语。
当然要在Word中处理了。（可能也有别的办法，请高手指教。）当然少不了循环，本贴主要解决的就是速度问题。
非常任务，利用Word整理词库。
今天的主要工作就是整理词库，从近30万词语中（包括重复的）筛选出Word可以识别近10万个词语。这项工作昨天就开始了。主要方法，就是没个词语一段，然后用vba判断每段的词语数即words.count ,如果等于2就是word可以识别的词语。发现在word中处理太多的就会导致速度非常慢。一次处理越少就越快。成千上万的词语对于耐心是一种考验。所以就需要多次的复制和粘贴。后来发现Word处理的一个小规律：
使用Word.ActiveDocument.Paragraphs (i)来读取和处理段落时，
for i=5000 to 4000 很慢而使用 for i=1000 to 1 两种相同数量的处理，速度却有天壤之别！改进了处理机制之后，速度提升很快，处理10000个词语平均用时200秒左右。详细代码：
'要求词语每个一行（一段）除了回车符，没有其他字符（一行只能有待处理的一个词语）
'词语中不能包含任何特殊格式（如拼音等）
'处理过的词语将保存在通目录的pinyin.txt中
'通过这个小程序，我们可以发现Word在循环处理方面的一个小窍门，处理的数字越小，速度越快
'所以如果允许，我们可以把处理过的东西删除掉，这样就保持了小数字的循环。
'处理过程中请必要切换程序，如果需要停止请按Ctrl+Break，然后还可以继续。

'请在Word主界面通过按钮运行该过程以便显示进度
'本机测试：
'windows XP office 2003 ,CPU 1.1G 内存 256M
'处理词语（段落）：10000个
'其中包含Word可以识别的词语：3495个
'用时：t=50 214.406秒，t=100 201.937秒，t=200 262.656秒
Dim myP As Paragraph
Dim LL, I, T, S, C, Tt As Long
Dim myDic, myDDD As String
Dim myW, myPy As String
Word.Application.ScreenUpdating = False
LL = Word.ActiveDocument.Paragraphs.Count '用于计数
myDic = ThisDocument.Path & "\pinyin.txt" '保存文件
T = 100 ' 这是一个关键值，以100个为一组，可以自己修改数字越大，速度越慢。太小也不好，循环太频繁也影响速度。
Tt = VBA.Timer
StartC:

On Error GoTo Er '处理200以内的情况
For I = T To 1 Step -1
    S = S + 1 '用于计数
    Set myP = Word.ActiveDocument.Paragraphs(I)
    myW = myP.Range.Text
    myW = Left(myW, Len(myW) - 1)
    Word.StatusBar = "正在处理： " & LL - S & Space(3) & myW '处理进度
        If myP.Range.Words.Count = 2 Then
        C = C + 1
        WritePrivateProfileStringByKeyName "拼音", myW, "1", myDic '使用api函数写入文本，可以保证无重复的情况
        End If
    myP.Range.Delete

Next
Word.ActiveDocument.UndoClear
If Word.ActiveDocument.Paragraphs(1).Range.Words.Count > 1 Then GoTo StartC '如果没有处理结束，继续下一组
Word.Application.ScreenUpdating = True
Word.ActiveDocument.Content.InsertAfter "处理词语（段落）：" & LL & "个" & vbCrLf & _
"其中包含Word可以识别的词语：" & C & "个" & vbCrLf & _
"用时：" & VBA.Timer - Tt & "秒"
Exit Sub
'设置T为实际段落数，继续处理
Er:
T = Word.ActiveDocument.Paragraphs.Count
GoTo StartC
End Sub

wjhere

谢谢关注，sylun 兄实则是委婉地批评了我呀，使用 for each 方法速度快得惊人，只用了20秒的时间，只是原来的十分之一呀！看来我昨天白白的浪费了很多时间呀！还以为发现什么新大陆呢。
Sub test()
Dim p As Paragraph, n As Integer,Tt as long
Tt = Timer
Application.ScreenUpdating = False
myDic = ThisDocument.Path & "\pinyin.txt"
For Each p In ThisDocument.Content.Paragraphs
    If p.Range.Words.Count = 2 Then
    myW = p.Range.Words(1)
    WritePrivateProfileStringByKeyName "拼音", myW, "1", myDic
  n = n + 1
     Debug.Print n & p.Range.Text
    End If
Next
MsgBox VBA.Timer - Tt & "秒"
Application.ScreenUpdating = True
End Sub
新的问题：可是有时候我们需要倒序循环怎么办?

sylun

文档有点怪。刚才用如下代码测试，发现有17个段落的words.count为1，用Ctrl+右方向键查看，光标是直接到下一段落的。
Sub test()
Dim p As Paragraph, a As String, n As Integer
Application.ScreenUpdating = False
For Each p In ThisDocument.Content.Paragraphs
    If p.Range.Words.Count = 1 Then
        n = n + 1
        a = a & n & vbTab & p.Range.Text
    End If
Next
Documents.Add.Content = a
MsgBox n
Application.ScreenUpdating = True
End Sub

守柔

这是我在处理Word中文词组（成语等）时用到的，供楼主参考：
Option Explicit

Sub Example1()
    Dim i As Paragraph
    Dim myRange As Range
    Dim myText As String
    Dim intLen As Integer
    Word.Application.ScreenUpdating = False
    For Each i In Me.Paragraphs
        myText = i.Range.Text
        intLen = InStr(myText, "|")
        If intLen > 0 Then
            Set myRange = i.Range
            myRange.Start = myRange.Start
            myRange.End = myRange.Start + intLen - 1
            '            Debug.Print myRange.Text
            If myRange.Words.Count > 1 Then i.Range.Delete
        End If
    Next
    Word.Application.ScreenUpdating = True
End Sub
Sub Example2()
    Dim i As Paragraph
    Dim myString As String
    Word.Application.ScreenUpdating = False
    For Each i In Me.Paragraphs
        If InStr(myString, Chr(13) & i.Range.Text) = 0 Then myString = myString & i.Range.Text
    Next
    Word.Documents.Add.Content.Text = myString
    Word.Application.ScreenUpdating = True
End Sub
我就不注释了，楼主能明白。
倘若你看过http://club.excelhome.net/viewth ... 3Ddigest&page=1此贴，当不会犯此错误了。
代码玩多了，你会发现，其实对象这个词，还有一个更专业的术语，叫“指针”或者句柄（hwnd)，在VB或者VBA中，我们是通过对象来编程的，在更低层的代码或者其他开发语言中，很多是使用指针的，指针是什么，指针就是一个对象的“牛鼻子”，或者说是一首诗的题目，知道了指针，也就知道了对象。
由此，我们可以知道，实际上如果一个程序，赋予了一个对象，那么通过对象的方法，则会很快，如果有这个对象的指针，则处理会更快。
倒序法，也要看实际情况，不能一概而论。

sylun

wjhere兄言重了。
我以前没有比较过step是正与负的差别，便对楼主测试感兴趣。用楼主的代码测试时觉得统计数据有出入，进而对文档中17个段落的words.count为1感觉到奇怪。
如对文档有任何改动，都可能会影响程序运行速度。关于这点我说不上道理来。印象中，for each... next语句的运行速度要比for...next语句快，随着word的操作记忆量（可撤销操作）增加，运行速度会受影响。不知我这样的认识是否正确。
我的代码只是避免对原文档作任何改动，我觉得似乎没有那个必要。当然，如果必须要对文档进行编辑，另当别论，这也是我对楼主的测试感兴趣的原因。
如果要倒序的结果，不知将我的代码中“a = a & n & vbTab & p.Range.Text”一句获取的字符串次排列序倒过来是否合适？不知wjhere兄要倒序处理的必要性。

wjhere

谢谢两位哥哥的耐心帮助，我明白一些了。都怪我平时读帖没有仔细，想不到速度竟然相差十万八千里呀。虽然付出了时间和精力，感到很值得。论坛真好，如果闭门造车，恐怕难以醒悟。多学习真的可以少走弯路。

sylun

我也是在学习。
刚才用如下代码测试，速度也可以：
Sub test()
Dim st As Single, p As Paragraph, n As Long
Dim fs, f
st = Timer
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile("c:\pinyin2.txt", True)
For Each p In ActiveDocument.Content.Paragraphs
    If p.Range.Words.Count < 3 Then
        n = n + 1
        f.Writeline Replace(p.Range.Text, Chr(13), "")
    End If
Next
f.Close
MsgBox n & vbTab & Timer - st
End Sub

wjhere

测试了一下，sylun兄的代码很快，和上面您给我的类似
Documents.Add.Content = a的那段处理速度相似。不过，有时候我们可能需要多次筛选，并把不重复的记录保存下来，我代码中使用的api就有了作用，当然速度就有了牺牲。

WritePrivateProfileStringByKeyName "拼音", myW, "1", myDic

冰风萧萧

不懂

lovecomputer

我发现这个循环不能结束呢，For Each p In ActiveDocument.Content.Paragraphs，查了一下资料，说这里如果要对paragraph操作，会导致paragraphs出错，建议用for啊