通过Word文档循环提取表格数据并放置到Excel中

我目前需要从Word表中提取数据并将其放入Excel中。 我可以在文件的基础上做到这一点。 我需要能够遍历文件path中的所有单词文档。

更具体地说，我需要能够打开一个单词文件，从这个单词文件的表中读取信息导入下面需要的信息，closures这个单词文件，然后在指定的所有单词文件（doc或docx）中重复夹。

目前我的代码是这样的：

Sub ImportWordTable() Dim eRow As Long Dim ele As Object Dim mainBook As Workbook Set mainBook = ActiveWorkbook mainBook.Sheets("Sheet1").Range("A:BB").Clear Set sht = Sheets("sheet1") Application.Goto (ActiveWorkbook.Sheets("Sheet1").Range("A1")) Dim wordDoc As Object Dim wdFileName As Variant Dim noTble As Integer Dim rowNb As Long Dim colNb As Integer Sheet1.Range("A1").Select Dim x As Long, y As Long x = 1: y = 1 Dim sPath As String Dim sFil As String Dim owb As Workbook Dim twb As Workbook wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _ "Browse for file containing table to be imported") If wdFileName = False Then Exit Sub Set wordDoc = GetObject(wdFileName) With wordDoc noTble = wordDoc.tables.Count If noTble = 0 Then MsgBox "No Tables in this document", vbExclamation, "No Tables to Import" Exit Sub End If For k = 1 To noTble With .tables(k) For rowNb = 1 To .Rows.Count For colNb = 1 To .Columns.Count Cells(x, y) = WorksheetFunction.Clean(.cell(rowNb, colNb).Range.Text) y = 0 Next colNb y = 1 Next rowNb End With x = x + 1 Next Range("A1").Select ActiveCell.Replace What:="Cotnact InformationName", Replacement:="", _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _ False, ReplaceFormat:=False ActiveCell.Replace What:="Email", Replacement:="", _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _ False, ReplaceFormat:=False ActiveCell.Replace What:="Contact InformationName", Replacement:="", _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _ False, ReplaceFormat:=False ActiveCell.Replace What:="Address", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="Location", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A1").Select ActiveCell.Replace What:="Phone", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="Cell", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="Fax", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="Re:", Replacement:=":", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A3").Select ActiveCell.Replace What:="Preferred Position and RoutePreferred Position(s)" _ , Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _ False, SearchFormat:=False, ReplaceFormat:=False ActiveCell.Replace What:="preferred Route(s)", Replacement:="", LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A4").Select ActiveCell.Replace What:="Experience ad skillsDriving experience", _ Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _ False, SearchFormat:=False, ReplaceFormat:=False ActiveCell.Replace What:="Experience and skillsDriving experience", _ Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _ False, SearchFormat:=False, ReplaceFormat:=False ActiveCell.Replace What:="trucks driven", Replacement:="", LookAt:=xlPart _ , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="other skills/experience", Replacement:="", _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _ False, ReplaceFormat:=False ActiveCell.Replace What:="licensingdriver License", Replacement:="", _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _ False, ReplaceFormat:=False Range("A5").Select ActiveCell.Replace What:="licensingdriver License", Replacement:="", _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _ False, ReplaceFormat:=False ActiveCell.Replace What:="license number", Replacement:="", LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="state/prov.", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="hazmat", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A6").Select ActiveCell.Replace What:="driving recordlicense ever suspended?", _ Replacement:=":", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _ False, SearchFormat:=False, ReplaceFormat:=False ActiveCell.Replace What:="DUI's", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="DUis", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveCell.Replace What:="moving violations in last 3 years", Replacement:= _ "", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False ActiveCell.Replace What:="preventable accidents in last 3 years", _ Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _ False, SearchFormat:=False, ReplaceFormat:=False ActiveCell.Replace What:="employment status", Replacement:="", LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A7").Select ActiveCell.Replace What:="employment status", Replacement:="", LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A8").Select ActiveCell.Replace What:="job history", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A2").Select ActiveCell.Replace What:="profile summary", Replacement:="", LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A9").Select ActiveCell.Replace What:="Resume", Replacement:="", LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A1:A6").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :=":", FieldInfo:=Array(Array(1, 2), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _ 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True Range("B9").Select Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B1:I1")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) Dim BlankRow As Long BlankRow = Range("A65000").End(xlUp).Row + 1 Cells(BlankRow, 1).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A2")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 9).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B3:C3")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 10).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B4:D4")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 12).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B5:F5")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 15).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B6:E6")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 20).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A7")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 24).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A8")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 25).Select ActiveSheet.Paste Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A9")) Selection.Copy Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2")) BlankRow = Range("A65000").End(xlUp).Cells(1, 26).Select ActiveSheet.Paste End With Set wordDoc = Nothing End Sub