VBA Word: более быстрое копирование из многих файлов в каталоге?

Прочитав множество источников и много копируя и вставляя, я придумал макрос для 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

и макрос работает так. Я также добавил таймер для расчета времени выполнения, и теперь макрос перебирает 173 файла примерно за 10 секунд :)

    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