Vba 是否从Microsoft Word中的表中检索文本？

我有这样一个word文档：

Table 1

Table 2
Some Text
My Value

我试图使用excel中的VBA从表2中检索文本，并将其放入我的工作表（“计算”）

由于某些原因，这不起作用，并且我的工作表上没有显示任何值。我没有错

这是我的密码：

Sub ImportWordTable()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
'Application.EnableEvents = False

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 = Worksheets("Calculations").Range("A1").Value & "\" & AlphaNumericOnly(Worksheets("Supplier").Range("O" & ActiveCell.Row).Value) & "_CAP_" & Replace(Worksheets("Supplier").Range("T" & ActiveCell.Row).Value, "/", ".") & ".doc"

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



With wdDoc
    TableNo = wdDoc.Tables.Count
    If TableNo = 0 Then

    ElseIf TableNo > 1 Then
        TableNo = "2"
    End If
    With .Tables(TableNo)
        'copy cell contents from Word table cells to Excel cells
        For iRow = 1 To Worksheets("Calculations").Rows.Count
            For iCol = 1 To Worksheets("Calculations").Columns.Count
                Cells(iRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
            Next iCol
        Next iRow
End With
End With


Set wdDoc = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub


Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

---

有人能告诉我哪里出错了吗？

为什么要在工作表的行和列之间循环

With .Tables(TableNo)
    'copy cell contents from Word table cells to Excel cells
    For iRow = 1 To Worksheets("Calculations").Rows.Count
        For iCol = 1 To Worksheets("Calculations").Columns.Count
            Cells(iRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
        Next iCol
    Next iRow
End With

您需要在表的行和列之间循环。试试这个（未经测试）

编辑

我测试了这个，它工作了

代码

Sub ImportWordTable()
    Dim oWordApp As Object, wdDoc As Object
    Dim iRow As Long, iCol As Long
    Dim excelRow As Long, excelCol As Long
    Dim Filename As String

    Filename = "C:\Users\Siddharth\Desktop\DeleteMeLater.docx"

    Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = True
    Set wdDoc = oWordApp.Documents.Open(Filename)

    With wdDoc
        If wdDoc.Tables.Count > 1 Then
            With .Tables(2)
                excelRow = 1
                'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    excelCol = 1
                    For iCol = 1 To .Columns.Count
                        Worksheets("Calculations").Cells(excelRow, excelCol) = _
                        WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        excelCol = excelCol + 1
                    Next iCol
                    excelRow = excelRow + 1
                Next iRow
            End With
        End If
    End With

    Set wdDoc = Nothing
End Sub

---

谢谢，但代码似乎没有修复/更改任何内容请参阅更新的帖子。您可能需要刷新页面。我可以看看您的word文件吗？

Sub ImportWordTable()
    Dim oWordApp As Object, wdDoc As Object
    Dim iRow As Long, iCol As Long
    Dim excelRow As Long, excelCol As Long
    Dim Filename As String

    Filename = "C:\Users\Siddharth\Desktop\DeleteMeLater.docx"

    Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = True
    Set wdDoc = oWordApp.Documents.Open(Filename)

    With wdDoc
        If wdDoc.Tables.Count > 1 Then
            With .Tables(2)
                excelRow = 1
                'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    excelCol = 1
                    For iCol = 1 To .Columns.Count
                        Worksheets("Calculations").Cells(excelRow, excelCol) = _
                        WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        excelCol = excelCol + 1
                    Next iCol
                    excelRow = excelRow + 1
                Next iRow
            End With
        End If
    End With

    Set wdDoc = Nothing
End Sub