Question

下面的测试代码检查ActiveDocument中的段落，并将唯一段落的“副本”放在文档底部，然后将其原始空格空白段落放在后面。将段落按数组处理，然后将合格的段落一个接一个地添加到该文档的底部。有没有更快的方法在其中添加这些段落？我希望有一种无需循环即可直接添加数组的方法。我认为可以在Excel中为范围分配数组（请参见Rick Rothstein），但我看不到如何在Word 2010中做到这一点。

Sub FullArray()
Dim StartTime                          'Start time
Dim p As Paragraph                     'is each initial paragraph object in ActiveDocument
Dim pDict As New Scripting.Dictionary  'Keys=plain text versions of each inital para
                                       'Items=signifiers of each key's (and para's)uniqueness or otherwise
Dim t As String                        'Plain text version of each p, being a key of pDict

Dim pArray(1000) As Variant            'Contains all initial paragraph objects
Dim c As Integer                       'c is ordinal number of each element of pArray
Dim dky As String                      'dky is whichever element of pArray is to be used as a key of pDict
Dim pc As Integer                      'running count of plain text paras in pDict
Dim lastdky As Integer                 'signifies whether previous key of pDict is unique
'faster when dimmed, option explicit

StartTime = Timer
Application.ScreenUpdating = False     'Line 1 of Go to end of doc
ActiveDocument.Characters.Last.Select  'Line 2 of Go to end of doc. Is there a Faster way?
Selection.Collapse

'ADD each para object to Array. Write its plain text to dictionary...
'...in order to determine uniqueness of each para.
For Each p In ActiveDocument.Paragraphs
    t = p.Range.Text
    If Not pDict.Exists(t) Then
        pDict.Add Key:=t, Item:=1   '1 flag means 1st instance of a para, including blamk paras
    Else: pDict(t) = 2              '2 flag means a para which has duplicates
    End If

    pc = pc + 1                     'count plain text paras in pDict
    pArray(pc) = p                  'set element number pc of Array = current paragraph object
Next p


'PLACE copies of certain paras at the end of document...
'...being those content-containing paras which were initially unique....
'...and place after each such para any following contiguous blank paras
lastdky = 1                         '2/1 means PREVIOUS initial paragraph had/had not dupes.
For c = pc - 1 To 1 Step -1
    dky = pArray(c)
    If pDict(dky) = 1 And pArray(c) <> Chr(13) Then Selection.FormattedText = pArray(c) 'place para with content ('content paras') at end
    If pArray(c) = Chr(13) And lastdky = 1 Then Selection.FormattedText = pArray(c)     'place (only) blank paras following content paras at end
    If pDict(dky) = 2 Then lastdky = 2 Else: lastdky = 1
Next c

MsgBox "This code ran successfully in " & Round(Timer - StartTime, 2) & " seconds", vbInformation
    Application.ScreenUpdating = True
End Sub

将段落数组添加到Word文档的快速方法

0 个答案: