将数据从Word表中的特定单元格导入到Excel中的特定单元格每次导入时，工作簿将在第一个空白行上启动

我用VBA脚本得到了一部分，我发现我稍作修改。 我需要从word表中导入一些信息到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 

斯科特的答案是正确的。 一些奇怪的数据或我的文件中的东西导致exception的行为，所以下面是什么在为我工作。

 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

您可以在工作表中find下一个可用的行，并在每次对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