現在、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