我目前需要从 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