VBA Word：从目录中的许多文件中更快地复制？

Question

在阅读了很多资料并复制粘贴了很多内容后，我想出了一个用于 MS Word 2010 的宏来计算我在一天结束时完成的工作。

它的作用：

1. 打开指定目录中的每个 DOCX 文件。
2. 从我用于翻译的两列表格的右侧复制文本。
3. 打开统计文件并将剪贴板粘贴到文件顶部。
4. 当没有更多文件需要处理时，宏会在统计文件顶部打印统计信息。

一切正常。但是，我想让它工作得更快。如果我使用宏来处理 50-100 个文件，它可能会在 10-15 到每秒 1 个文件之后减慢。我很茫然。我想我没有为这项工作选择正确的工具。 我可以让这段代码运行得更快吗？

我尝试过：

1. 将参数传递给打开文件命令（AddToRecentFiles:=False，这增加了可以忽略不计的改进）。

2.将 Window.Visible = False 设置为子例程，但随后宏不会复制任何文本。

我什至不确定 oDoc 的作用：

Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)

大量的谷歌搜索，只有基本知识的复制粘贴。对于那个很抱歉。但我愿意学习。

'Create variables to use later
Dim vDirectory As String
Dim vFileTarget As String
Dim vStat1 As Variant
Dim vStat2 As Variant
'Variables to clear clipboard in case of errors
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long

Sub GoodStats()
vDirectory = "C:\Users\Job\Calculate\" 'Files to process
vFile = Dir(vDirectory & "*.docx*") 'Extension of the files to process
vFileTarget = "C:\Users\Job\stats.docx" 'File for the final count
Application.ScreenUpdating = False
DeleteOld 'Prepare final count file for new calculation
Do While vFile <> "" 'Get this show on the road
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
TextCopy
TextMove
vFile = Dir
Loop
'Proceed to next function because there are no files left to process
FinalRun
Application.ScreenUpdating = True
End Sub

Function DeleteOld()
'Previous statistics is deleted from final count file
Documents.Open FileName:=vFileTarget
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveDocument.Save
End Function

'Primary cycle of document open, copy, paste begins
Function TextCopy() 'Copy text from right part of the table
    On Error GoTo ErrorHandler 'Goes to error handler if there is no text on the right side
    Selection.MoveRight Unit:=wdCell
    Selection.Copy
    ActiveWindow.Close
    Exit Function
ErrorHandler:     'If there is no text, close document, proceed to next function
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
    ActiveWindow.Close
    Exit Function
End Function

Function TextMove() 'Move copied text to final count file
On Error GoTo ErrorHandler
Documents.Open FileName:=vFileTarget
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.HomeKey Unit:=wdLine
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.HomeKey Unit:=wdStory
ActiveDocument.Save
ActiveWindow.Close
ErrorHandler:     'If error, close document and move on
    Exit Function
End Function

Function FinalRun()
'Open the final count file to calculate statistics
Documents.Open FileName:=vFileTarget
Selection.HomeKey Unit:=wdStory
'Calculate number of symbols and spaces
vStat1 = ActiveDocument.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces)
'Translation pages = symbols + spaces divide by 1860
vStat2 = Round((ActiveDocument.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces) / 1860), 2)
Selection.TypeText Text:=vStat1 & " symbols with spaces" 'First statistics line
Selection.TypeParagraph
Selection.TypeText Text:=vStat2 & " translated pages"
'Money = pages multiplied by 10000
Selection.TypeParagraph
Selection.TypeText Text:=vStat2 * 10000 & " rubles for all the translations"
ActiveDocument.Save
End Function

更新

感谢 KazJaw 我现在有了我想要的宏。非常感谢您指导我使用 Range 功能。新宏不会复制文件，而是从每个文件中的选择中逐一计算统计数据，将所有数字相加并在消息框中显示结果。而且确实感觉更快。

更新 2

我已经添加了

Application.Visible = False

宏就是这样工作的。我还添加了一个计时器来计算执行时间，现在宏在大约 10 秒内循环了 173 个文件:)

    Sub GoodStats()
'Create variables to use later
Dim vDirectory As String
Dim charCount As Single
Dim tcharCount As Single
Dim pageCount As Single
Dim moneyCount As Single
Dim myRange As Range
Dim startTime As Double
'Clear basic statistics number if you run macro multiple times
tcharCount = 0
startTime = Timer
'Folder to process
vDirectory = "C:\Users\Job\Calculate\"
'Extension of the files to process
vFile = Dir(vDirectory & "*.docx*")
'Don't want all those files popping up
Application.ScreenUpdating = False
Application.Visible = False
'Get this show on the road
Do While vFile <> ""
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
'Switch to the right column
Selection.MoveRight unit:=wdCell
    Set myRange = ActiveDocument.Range(Selection.Start, Selection.End)
    'Get the initial number
    charCount = myRange.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces)
    'Add the current document stats to overall stats
    tcharCount = tcharCount + charCount
    ActiveWindow.Close
vFile = Dir
Loop
'Translation pages = symbols + spaces divide by 1860
pageCount = Round((tcharCount / 1860), 2)
moneyCount = pageCount * 10000
Application.ScreenUpdating = True
Application.Visible = True
Done = Timer - startTime
'Show the results in a message box with multiple lines
MsgBox tcharCount & " total characters" & vbCrLf & _
pageCount & " total pages" & vbCrLf & _
moneyCount & " total money" & vbCrLf & _
"Done in " & Done & " seconds"
End Sub

Answer 1

首先 - 打开和关闭文档非常耗时！

其次，选择通常是处理 Word 文档、Excel 范围、Office 形状等的低效方式。 相反，您可以尝试设置对Object Variable 的引用并通过使用variable 来操作您的文本。但是，它需要对您的代码进行一些更改并采用不同的方法。

您将在下面找到我从Selection approach 转换为Object Variable approach 的部分代码(Function TextMove())。我保留了您的代码（在 cmets 中），以便您可以比较代码的内容而不是代码的哪一部分。这段代码做同样的事情，但它应该运行得更快。

Function TextMove() 'Move copied text to final count file
On Error GoTo ErrorHandler
Documents.Open FileName:=vFileTarget
Selection.PasteAndFormat (wdFormatOriginalFormatting)

   'CHANGES AS OF THIS SECTION
        Dim myRange As Range
        Selection.HomeKey unit:=wdStory
            'Selection.EndKey unit:=wdLine, Extend:=wdExtend
        Set myRange = ActiveDocument.Range(0, Selection.EndKey(wdLine, wdExtend))
            'Selection.Font.Bold = wdToggle
        myRange.Font.Bold = wdToggle
            'Selection.HomeKey unit:=wdLine
            'Selection.TypeParagraph
            'Selection.TypeParagraph
            'Selection.TypeParagraph
        myRange.InsertBefore Chr(13) & Chr(13) & Chr(13)
            'Selection.HomeKey unit:=wdStory
        myRange.MoveStart wdStory  '<< but you rather don't need it
   'END OF CHANGES 

    ActiveDocument.Save
    ActiveWindow.Close
ErrorHandler:     'If error, close document and move on
    Exit Function
End Function