循环通过Word文档提取表数据并放入Excel

Question

我目前需要从Word表中提取数据并将其放入Excel。我可以逐个文件地执行此操作。我需要能够遍历文件路径中的所有word文档。

更具体地说，我需要能够打开一个word文件，从该word文件中的表中读取信息，导入下面所需的信息，关闭该word文件，然后重复所有word文件（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