Просматривая папку файлов слов, чтобы скопировать все таблицы слов в файл Excel с ошибкой в ​​отдельном листе на слово

Question

Как уже упоминалось в заголовке, у меня есть папка с файлами слов, и я хочу скопировать из этих файлов все таблицы в отдельные листы. Я пытался адаптировать решения из Интернета, но ни одно из них не работает (или, возможно, я не применил их правильно).

Я сталкиваюсь с ошибкой

1004 "Метод 'Вставить' объекта '_Worksheet' не выполнен"

или иногда он не может копировать / вставлять из-за слияния ячеек. В строке отображается код:

WkSht.Paste Destination:=WkSht.Range("A" & r)

Что странно, когда я перезапускаю макрос, он проходит правильно через все файлы в папке. Но иногда приходится убивать слово в диспетчере задач из-за ошибки OLE

«Microsoft Excel ожидает, пока другое приложение завершит действие OLE.»

Выбор файла, Параметры, Дополнительно и в разделе Общие игнорировать другие приложения, использующие DDE, не помогает.

Public wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
Public strFolder As String, strFile As String, WkBk As Workbook, WkSht As Worksheet, r As Long

Sub GetTableData()

Application.ScreenUpdating = False
Dim x As Integer

strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkBk = ActiveWorkbook
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc*", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Set WkSht = WkBk.Sheets.Add
x = x + 1
WkSht.Name = Mid(strFile, 20, 29) & x

With wdDoc
For Each wdTbl In .Tables
  With wdTbl.Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[^13^l]"
    .Replacement.Text = "¶"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
   End With
  r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
  If r > 1 Then r = r + 2
  wdTbl.Range.Copy
  WkSht.Paste Destination:=WkSht.Range("A" & r)
Next
WkSht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Function sheet_exists(sheet_to_find As String) As Boolean

Dim work_sheet As Worksheet

sheet_exists = False
For Each work_sheet In ThisWorkbook.Worksheets
    If sheet_to_find = work_sheet.Name Then
        sheet_exists = True
        Exit Function
    End If
Next work_sheet

End Function