从Microsoft Word中的表中检索文本？

Question

我有一个像这样的文字文件：

Table 1

Table 2
Some Text
My Value

我正在尝试在excel中使用VBA来检索表2中的文本并将其放入我的工作表中（＆＃34;计算＆＃34;）。

由于某种原因，这不起作用，我的工作表上没有出现任何值。我没有错。

这是我的代码：

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

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

Answer 1

为什么要循环遍历工作表的行和列？

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

您需要遍历表格行和列。试试这个（未经测试）

Dim excelRow As Long, excelCol As Long

excelRow = 1

With .Tables(TableNo)
    '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

修改

我对此进行了测试，正常工作

<强>代码

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