Sub ImportWordTableIntoExcel()
Dim wdDoc As Object
Dim TableNo As Integer 'table number in Word
Dim nRow As Long 'row index in Excel
Dim nCol As Long 'row index in Excel
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim fileNameArr(0 To 1) As String
fileNameArr(0) = "C:\Documents\A1.doc"
fileNameArr(1) = "C:\Documents\A2.doc"
nRow = 1
For fileNam = LBound(fileNameArr) To UBound(fileNameArr)
Set wdDoc = GetObject(fileNameArr(fileNam)) 'open Word file
With wdDoc
TableNo = wdDoc.tables.Count
If TableNo > 2 Then
With .tables(TableNo - 3)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
nCol = 1
Cells(nRow, nCol) = fileNameArr(fileNam)
nCol = nCol + 1
For iCol = 1 To .Columns.Count
Cells(nRow, nCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
nCol = nCol + 1
Next iCol
nRow = nRow + 1
Next iRow
End With
End If
End With
Set wdDoc = Nothing
Next fileNam
End Sub
Dim wdDoc As Object
Dim TableNo As Integer 'table number in Word
Dim nRow As Long 'row index in Excel
Dim nCol As Long 'row index in Excel
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim fileNameArr(0 To 1) As String
fileNameArr(0) = "C:\Documents\A1.doc"
fileNameArr(1) = "C:\Documents\A2.doc"
nRow = 1
For fileNam = LBound(fileNameArr) To UBound(fileNameArr)
Set wdDoc = GetObject(fileNameArr(fileNam)) 'open Word file
With wdDoc
TableNo = wdDoc.tables.Count
If TableNo > 2 Then
With .tables(TableNo - 3)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
nCol = 1
Cells(nRow, nCol) = fileNameArr(fileNam)
nCol = nCol + 1
For iCol = 1 To .Columns.Count
Cells(nRow, nCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
nCol = nCol + 1
Next iCol
nRow = nRow + 1
Next iRow
End With
End If
End With
Set wdDoc = Nothing
Next fileNam
End Sub
No comments:
Post a Comment