vba - 将 Word 表格中特定单元格的数据导入 Excel 工作簿中的特定单元格，每次导入时从第一个空白行开始

Question

我发现我稍微修改了一个 VBA 脚本，这其中的一部分。我需要将单词表中的一些信息导入excel。我遇到的问题是脚本覆盖了第一行，每次使用它时我都需要它转到第一个空白行。

这是我所拥有的:

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

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.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

With wdDoc
TableNo = 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 table number of table to import", "Import Word Table", "1")
End If

'Range("A1") = "Table #"
'Range("B1") = "Cell (3,2)"
'Range("C1") = "Cell (4,2)"

For iTable = 1 To TableNo
With .tables(TableNo)
'copy cell contents from Word table cells to Excel cells
'copy cell contents from Word table cells to Excel cells in column B and C
Cells(iTable + 1, "A") = WorksheetFunction.Clean(.cell(14, 2).Range.Text)
Cells(iTable + 1, "B") = WorksheetFunction.Clean(.cell(2, 2).Range.Text) 'need to post current date
Cells(iTable + 1, "C") = WorksheetFunction.Clean(.cell(16, 2).Range.Text)
Cells(iTable + 1, "D") = WorksheetFunction.Clean(.cell(15, 2).Range.Text)
Cells(iTable + 1, "E") = WorksheetFunction.Clean(.cell(1, 2).Range.Text)
Cells(iTable + 1, "H") = WorksheetFunction.Clean(.cell(7, 2).Range.Text)
Cells(iTable + 1, "I") = WorksheetFunction.Clean(.cell(8, 2).Range.Text)
Cells(iTable + 1, "S") = WorksheetFunction.Clean(.cell(3, 2).Range.Text) 'need to post name of negotiatoe
End With
Next iTable
End With

斯科特的回答对此是正确的。数据或我的文件中的某些东西奇怪导致异常行为，所以下面是对我有用的东西。

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

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.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

With wdDoc
TableNo = 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 table number of table to import", "Import Word Table", "1")
End If

'Range("A1") = "Table #"
'Range("B1") = "Cell (3,2)"
'Range("C1") = "Cell (4,2)"

For iTable = 1 To TableNo

       Dim lRow As Long
       lRow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row + 1

        With .tables(TableNo)

            'copy cell contents from Word table cells to Excel cells
            'copy cell contents from Word table cells to Excel cells in column B and C
            Cells(lRow - 1, "A") = WorksheetFunction.Clean(.cell(14, 2).Range.Text)
            Cells(lRow - 1, "B") = WorksheetFunction.Clean(.cell(2, 2).Range.Text) 'need to post current date
            Cells(lRow - 1, "C") = WorksheetFunction.Clean(.cell(16, 2).Range.Text)
            Cells(lRow - 1, "D") = WorksheetFunction.Clean(.cell(15, 2).Range.Text)
            Cells(lRow - 1, "E") = WorksheetFunction.Clean(.cell(1, 2).Range.Text)
            Cells(lRow - 1, "H") = WorksheetFunction.Clean(.cell(7, 2).Range.Text)
            Cells(lRow - 1, "I") = WorksheetFunction.Clean(.cell(8, 2).Range.Text)
            Cells(lRow - 1, "S") = WorksheetFunction.Clean(.cell(3, 2).Range.Text) 'need to post name of negotiatoe

        End With

Next iTable
End With

Set wdDoc = Nothing

End Sub

Answer 1

您可以在工作表中找到下一个可用行，并在每次对您的 For Loop 进行以下修改后写入该行。

For iTable = 1 To TableNo

       Dim lRow As Long
       lRow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row +1

        With .tables(TableNo)

            'copy cell contents from Word table cells to Excel cells
            'copy cell contents from Word table cells to Excel cells in column B and C
            Cells(lRow, "A") = WorksheetFunction.Clean(.cell(14, 2).Range.Text)
            Cells(lRow, "B") = WorksheetFunction.Clean(.cell(2, 2).Range.Text) 'need to post current date
            Cells(lRow, "C") = WorksheetFunction.Clean(.cell(16, 2).Range.Text)
            Cells(lRow, "D") = WorksheetFunction.Clean(.cell(15, 2).Range.Text)
            Cells(lRow, "E") = WorksheetFunction.Clean(.cell(1, 2).Range.Text)
            Cells(lRow, "H") = WorksheetFunction.Clean(.cell(7, 2).Range.Text)
            Cells(lRow, "I") = WorksheetFunction.Clean(.cell(8, 2).Range.Text)
            Cells(lRow, "S") = WorksheetFunction.Clean(.cell(3, 2).Range.Text) 'need to post name of negotiatoe

        End With

Next iTable