Excel VBA copy table from word to excel - excel

Question

I am updating this post with update code.
Sub ImportWordTable()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
'On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (.doc; .docx),.doc;.docx", 2, _
"Browse For file containing table To be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '(user cancelled import file browser)
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
'Range("A:AZ").ClearContents
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
"Enter the table To start from", "Import Word Table", "1")
End If
' Set the header for the Colums
With .tables(tableNo)
Parent.Range("A" & LastRow).Value = .cell(1, 1).Range
Parent.Range("B" & LastRow).Value = .cell(2, 1).Range
Parent.Range("C" & LastRow).Value = .cell(3, 1).Range
Parent.Range("D" & LastRow).Value = .cell(4, 1).Range
Parent.Range("E" & LastRow).Value = .cell(5, 1).Range
Parent.Range("F" & LastRow).Value = .cell(6, 1).Range
Parent.Range("G" & LastRow).Value = .cell(7, 1).Range
Parent.Range("H" & LastRow).Value = .cell(8, 1).Range
Parent.Range("I" & LastRow).Value = .cell(9, 1).Range
Parent.Range("J" & LastRow).Value = .cell(10, 1).Range
Parent.Range("K" & LastRow).Value = .cell(11, 1).Range
Parent.Range("L" & LastRow).Value = .cell(12, 1).Range
Parent.Range("M" & LastRow).Value = .cell(13, 1).Range
Parent.Range("N" & LastRow).Value = .cell(14, 1).Range
Parent.Range("O" & LastRow).Value = .cell(15, 1).Range
Parent.Range("P" & LastRow).Value = .cell(16, 1).Range
Parent.Range("Q" & LastRow).Value = .cell(17, 1).Range
Parent.Range("R" & LastRow).Value = .cell(18, 1).Range
Parent.Range("S" & LastRow).Value = .cell(19, 1).Range
Parent.Range("T" & LastRow).Value = .cell(20, 1).Range
Parent.Range("U" & LastRow).Value = .cell(21, 1).Range
Parent.Range("V" & LastRow).Value = .cell(22, 1).Range
Parent.Range("W" & LastRow).Value = .cell(23, 1).Range
Parent.Range("X" & LastRow).Value = .cell(24, 1).Range
Parent.Range("Y" & LastRow).Value = .cell(25, 1).Range
End With
LastRow = LastRow + 1
' Get the date from the tables
For tableStart = tableNo To tableTot
With .tables(tableStart)
.cell(1, 2).Range.Copy
With Range("A" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(2, 2).Range.Copy
With Range("B" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(3, 2).Range.Copy
With Range("C" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(4, 2).Range.Copy
With Range("D" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(5, 2).Range.Copy
With Range("E" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(6, 2).Range.Copy
With Range("F" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(7, 2).Range.Copy
With Range("G" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(8, 2).Range.Copy
With Range("H" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(9, 2).Range.Copy
With Range("I" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(10, 2).Range.Copy
With Range("J" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(11, 2).Range.Copy
With Range("K" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(12, 2).Range.Copy
With Range("L" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(13, 2).Range.Copy
With Range("M" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(14, 2).Range.Copy
With Range("N" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(15, 2).Range.Copy
With Range("O" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(16, 2).Range.Copy
With Range("P" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(17, 2).Range.Copy
With Range("Q" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(18, 2).Range.Copy
With Range("R" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(19, 2).Range.Copy
With Range("S" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(20, 2).Range.Copy
With Range("T" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(21, 2).Range.Copy
With Range("U" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(22, 2).Range.Copy
With Range("V" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(23, 2).Range.Copy
With Range("W" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(24, 2).Range.Copy
With Range("X" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(25, 2).Range.Copy
With Range("Y" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
End With
LastRow = LastRow + 1
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
It is working but having only one issue. if a cell is having multiple paragraph then it's getting pasted in multiple row of excel. I want like if 2nd column of 1st row of word file is having 3 paragraph, then in excel as well all these 3 paragraph should get pasted in same column.
Word Input
Excel File Output
Hope I am able to explain it properly.

Answer 1

I have amended your script to produce the desired results.
The clear contents and targeting is removed as this will allow other word tables to be added to the same sheet, amend the script if you want to clear the sheet each time.
The table start selection now works by setting the tableNo as the start of the loop
It pulls the heading from the first column of the first selected tableNo
VBA Script:
Sub ImportWordTable()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
'On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse For file containing table To be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '(user cancelled import file browser)
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
'Range("A:AZ").ClearContents
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
"Enter the table To start from", "Import Word Table", "1")
End If
' Set the header for the Colums
With .tables(tableNo)
Parent.Range("A" & LastRow).Value = .Cell(1, 1).Range
Parent.Range("B" & LastRow).Value = .Cell(2, 1).Range
Parent.Range("C" & LastRow).Value = .Cell(3, 1).Range
End With
LastRow = LastRow + 1
' Get the date from the tables
For tableStart = tableNo To tableTot
With .tables(tableStart)
.Cell(1, 2).Range.Copy
With Range("A" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.Cell(2, 2).Range.Copy
With Range("B" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.Cell(3, 2).Range.Copy
With Range("C" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
End With
LastRow = LastRow + 1
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub

Answer 2

As I said in my above comment, one Word table column cannot copy directly, not having a range property. Two ways are recommended, to avoid copying of each table cell, which consumes Excel resources and is very slow. One way would be to select the respective column (VBA allows it) and copy/paste selection. But using clipboard it is slow for more involved documents.
The most efficient way is to place the column range in an array (working only in memory) and drop its content, at once, in the necessary range. Then, try to format it. Copying the format from Word is also slow and consumes resources. I used a trick: Transforming the dropped array content range in an listObject, then UnList it. To benefit of the standard table format. If you need them to be tables, you have to comment the code line tbl.UnList:
Sub ImportWordTable()
Dim WordApp As Object, WordDoc As Object, ws As Worksheet
Dim arrFileList As Variant, FileName As Variant, tableNo As Integer
Dim tableStart As Integer, tableTot As Integer, Target As Range
Set ws = ActiveSheet 'it is good to fully qualify all the objects
'so, use here the sheet you need
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '(user cancelled import file browser)
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
ws.Range("A:A").Clear 'clear its format, too...
Set Target = ws.Range("A1")
Dim i As Long, tbl As ListObject
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.count
tableTot = WordDoc.tables.count
If tableNo = 0 Then
MsgBox WordDoc.name & " contains no tables", vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.name & " contains " & tableNo & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If
For tableStart = tableNo To tableTot 'start iteration from `tableNo` if not the default...
Dim arr: ReDim arr(1 To .tables(tableStart).rows.count, 1 To 1) 'declare and ReDim the necessary aray
With .tables(tableStart)
For i = 1 To .rows.count 'load the array with the second column content
arr(i, 1) = .Range.Columns(2).cells(i)
arr(i, 1) = left(arr(i, 1), Len(arr(i, 1)) - 1) 'eliminate the Word strange ending line character
Next i
With Target.Resize(.rows.count, 1)
.Value = arr
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range(.address), , xlYes) 'make the range a table
tbl.Unlist 'just transforming the table in range, but keeping its format...
End With
Set Target = Target.Offset(.Rows.Count + 2) 'reset Target
End With
Next tableStart
.Close False 'close the open document, without saving it
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing: Set WordApp = Nothing
End Sub