Не удается импортировать таблицу Word в Excel в GetObject

Question

Я пытаюсь скопировать содержимое таблицы из word в excel. Я запустил приведенный ниже код, и он не работает в GetObject, ЕСЛИ Я уже открыл слово do c, и в этом случае код работает нормально. Это известная проблема с Excel 2010? Мне не удалось воспроизвести проблему с Excel 365

Sub ImportWordTable()
    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim TableNo As Integer 'table number in Word
    Dim iRow As Long 'row index in Excel
    Dim iCol As Integer 'column index in Excel

    wdFileName = Application.GetOpenFilename("Word files,*.doc;*.docx", , _
    "Browse for file containing table to be imported")

    If wdFileName = False Then Exit Sub '(user cancelled import file browser)

    Set wdDoc = GetObject(wdFileName) 'open Word file

Пересмотренный код ниже (благодаря @Darren Bartrup-Cook), он проходит через объект Create или Get в зависимости от состояния Word. Он по-прежнему возвращает Ошибка автоматизации - указанная c процедура не может быть найдена , если у меня нет документа, уже открытого

Sub Test2()

    Dim oWD_App As Object
    Dim oWD_Doc As Object
    Dim WordFilename As Variant
    Dim ws As Worksheet
    Set ws = shImportBuffer
    Dim filter As String
    filter = "Word File Old (*.doc), *.doc," & _
    "Word File New (*.docx), *.docx,"

    'clear all of the content in the worksheet where the tables from the Word document are to be imported
    ws.Cells.ClearContents

    'displays a Browser that allows you to select the Word document that contains the table(s) to be imported into Excel
    WordFilename = Application.GetOpenFilename(filter, , "Select Word file")
    If WordFilename = False Then Exit Sub

    'call function
    Set oWD_App = CreateWord

    With oWD_App
        Set oWD_Doc = .Documents.Open(WordFilename)
    End With

End Sub


Public Function CreateWord(Optional bVisible As Boolean = True) As Object

    Dim oTempWD As Object
    'attempt GetObject
    On Error Resume Next
    Set oTempWD = GetObject(, "Word.Application")

    'if error then CreateObject rather than get
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo ERROR_HANDLER
        Set oTempWD = CreateObject("Word.Application")
    End If

    oTempWD.Visible = bVisible
    Set CreateWord = oTempWD

    On Error GoTo 0
    Exit Function

ERROR_HANDLER:
    Select Case Err.Number

        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure CreateWord."
            Err.Clear
    End Select

End Function

Answer 1

Как насчет этого?

Sub Test()


Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer
Dim wkSht As Worksheet

On Error Resume Next

ActiveSheet.Range("A:AZ").ClearContents

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.doc", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file

With wdDoc
    tableNo = wdDoc.Tables.Count
    tableTot = wdDoc.Tables.Count
    If tableNo = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
            'ElseIf tableNo > 1 Then
            ' tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
            ' "Enter the table to start from", "Import Word Table", "1")
    End If

    resultRow = 1

    For tableStart = 1 To tableTot
        With .Tables(tableStart)
            'copy cell contents from Word table cells to Excel cells
            For iRow = 1 To .Rows.Count
                For iCol = 1 To .Columns.Count
                    wkSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                Next iCol

                With wkSht
                    .Range(.Cells(resultRow, 1), .Cells(resultRow, iCol)).Interior.ColorIndex = 15
                End With

                resultRow = resultRow + 1
            Next iRow
        End With
        'resultRow = resultRow + 1
    Next tableStart
End With


End Sub