Копирование данных из Word в Excel, получение сообщения об ошибке: DataObject: GetText OpenClipboardFailed

Question

Я довольно новичок в VBA.У меня есть документ Microsoft Word с текстом, который содержит много сокращений.(до сотен)

Используя Excel VBA, я хочу автоматически создать таблицу сокращений в Excel: Для этого откройте документ Word -> Поиск сокращений -> Скопируйте каждый из них по одномуодин и вставьте в массив -> Затем вставьте этот массив в мой рабочий лист Excel -> Уничтожение дубликатов и сортируйте его -> Затем сравните аббревиатуры с помощью интересной базы данных на другом листе и заполните всю таблицу

Мне удалось выполнить все свои задачи, однако иногда при запуске макроса я получаю следующую ошибку:

DataObject: GetText OpenClipboardFailed

Иногда это случается, иногда это не так.Несоответствие сводит меня с ума.(И да, я пытался очистить свой буфер обмена без какого-либо существенного результата)

Не могли бы вы взглянуть на мой код и сказать мне, что может быть источником моих проблем?

Для clearclipboard функция:

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

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

Public Function ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Function

Фактическая часть кода:

Dim wrdApp As Object
Dim wrdDoc As Object
Dim TheArray() As String
Dim i As Integer
i = 0
Dim H As Integer

Dim TableSheet As Worksheet
Dim DataSheet As Worksheet

Set TableSheet = Worksheets("Create Abbreviation Table")
Set DataSheet = Worksheets("Abbreviation Database")


Set wrdApp = CreateObject("Word.Application") 
'Word.Application
wrdApp.Application.AutomationSecurity = 
msoAutomationSecurityForceDisable
Set wrdDoc = wrdApp.Documents.Open(FilePath, 
ReadOnly:=True, Visible:=False)


Dim wrksht As Worksheet
Dim Output As ListObject ' <-- Declare as ListObject
Dim MyData As DataObject

Call ClearClipboard
Set r = wrdDoc.Content
    With r
        .Find.ClearFormatting
       With .Find
            .Text = "<[A-Z]{2;5}>"
            .Forward = True
            .MatchWildcards = True
            .Format = False
            .MatchCase = False
           .MatchWholeWord = False

            Do While .Execute = True

                ReDim Preserve TheArray(i)
                r.Copy
                Set MyData = New DataObject
                MyData.GetFromClipboard 'This is where I mostly get error
                TheArray(i) = MyData.GetText(1)
                i = i + 1
                Call ClearClipboard
            Loop
        End With

     End With
    H = i + 4
    Sheets("Create Abbreviation Table").Select
    TableSheet.Range("N5").Select

    TableSheet.Range("N5:N" & H).Value = WorksheetFunction.Transpose(TheArray)

wrdDoc.Close
wrdApp.Quit

'Remove Duplicates
 TableSheet.Range("Output[#All]").RemoveDuplicates 
Columns:=1, Header:= _
xlYes

'Sort A-Z
    TableSheet.ListObjects("Output"). _
    Sort.SortFields.Clear
    TableSheet.ListObjects("Output"). _
    Sort.SortFields.Add Key:=Range("Output[[#All],. [Abbreviation]]"), SortOn:= _
    xlSortOnValues, Order:=xlAscending, 
DataOption:=xlSortNormal
With TableSheet.ListObjects( _
    "Output").Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

'Create array from table
Dim SortedTable As ListObject
Dim FoundDataArray As Variant
Dim k As Long
Dim m As Integer

Set SortedTable = Sheets("Create Abbreviation 
Table").ListObjects("OutPut")
FoundDataArray = SortedTable.DataBodyRange

For k = LBound(FoundDataArray) To UBound(FoundDataArray)
    m = Search(FoundDataArray(k, 1))

     If m = 0 Then
         FoundDataArray(k, 2) = ""

    Else
        FoundDataArray(k, 2) = DataArray(m, 2)
    End If
Next k


SortedTable.DataBodyRange = FoundDataArray