Copy selection of Word tables to Excel - excel

Question

I have modified the code from Macro to export MS Word tables to Excel sheets to copy a sequential interval of tables (e.g. 1 to 4) instead of copying all tables, as in the original code.
But I cannot figure out how to copy a selection of tables in the Word document (e.g. tables 1, 3, 7, 8).
Help to tweak the relevant section of code much appreciated!
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies sequential interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
The entire macro is:
Sub ImportWordTables()
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 Target As Range
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 = False
Range("A:AZ").ClearContents
Set Target = Worksheets("MySheet").Range("A1")
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"
End If
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub

Answer 1

You could supply the list of tables as an array. I added this to the restructured code below. You provide a variant containing an array of the table numbers you want to copy to the ImportWordTables sub. I'll leave it to you to modify the code by making the parameter optional so that you either copy all tables or the tables in the list.
Option Explicit
Public Enum TableImportError
NoTables
UnexpectedIndex
End Enum
Public Sub ImportWordTables(ByVal ipTableList As Variant)
Dim arrFileList As Variant
If Not TryGetFileNameList(arrFileList) Then Exit Sub
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
' the range should be qualified by the relevant wb/ws
Range("A:AZ").ClearContents
Dim FileName As Variant
For Each FileName In arrFileList
Dim WordDoc As Object
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
Dim myReason As TableImportError
If Not TryImportTables(WordDoc, ipTableList, myReason) Then
Select Case myReason
Case TableImportError.NoTables
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
Case TableImportError.UnexpectedIndex
MsgBox WordDoc.Name & "Unexpected index", vbExclamation, "The table indexes exceed the total table count. No tables copies"
End Select
End If
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Private Function TryGetFileNameList(ByRef opFileList As Variant) As Boolean
On Error Resume Next
opFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
On Error GoTo 0
TryGetFileNameList = IsArray(opFileList)
End Function
Private Function TryImportTables(ByRef ipDoc As Word.Document, ByVal ipTableList As Variant, ByRef opReason As TableImportError) As Boolean
TryImportTables = False
If ipDoc.Tables.Count = 0 Then
opReason = TableImportError.NoTables
Exit Function
End If
Dim myTable As Variant
For Each myTable In ipTableList
If myTable > ipDoc.Tables.Count Then
opReason = TableImportError.UnexpectedIndex
Exit Function
End If
Next
For Each myTable In ipTableList
With ipDoc.Tables.Item(myTable)
.Range.Copy
' replaced Target by worksheet refernce
' ideally this item should be passed as a parameter
' or second best defined as a module level variable.
'
' worksheets should be qualified by the relevant wb
With Worksheets("MySheet")
.Activate
.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
Set .Range("A1") = .Range("A1").Offset(.Rows.Count + 2, 0)
'.Paste
End With
End With
Next
TryImportTables = True
End Function
The code above compiles and doesn't give any unexpected Code Inspection warning by the free and fantastic Rubberduck addin for VBA. However as its a radical restructuring I can't guarantee it will work exactly as you previous code so please do check if you decide to use it.

Answer 2

Set this code of yours as a Function that you call from the Main Sub with the a TableIndex
With .tables(tableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Set the tableIndex variable as a Random number assigned from the collection of tables in the Word document. You'll have to decide how many times you will iterate thru the code so you get the random sample size you want but the basic code might look like this:
Sub ReturnRandomNumber()
Dim TableIndex As Integer
Dim WordDoc As Word.Document
Randomize
TableIndex = Int((WordDoc.Tables.Count * Rnd) + 1)
CopyRandomTable WordDoc, TableIndex
End Sub
Function CopyRandomTable(ByRef WordDoc As Word.Document, ByRef TableIndex As Integer)
With WordDoc.Tables(TableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.rows.Count + 2, 0)
End With
End Function
The RND function might also return the same table index so you should think about how you might want to deal with that ... like possibly setting up an array of table indexes already used and then act accordingly.
For more information about Randomize and the RND function here is a Microsoft Article on the RND Function.

Answer 3

Solved, but input box and memory capacity issue still to be fixed.
Replace With .tables(tableIndex) section in my first example above with the following:
'For array
Dim tables() As Variant
Dim tableCounter As Long
tables = Array(1, 3, 7) '<- define array manually here
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
.Range.Copy
Target.Activate
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False '<- gives RAM capacity problems!
ActiveSheet.Paste '<- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableCounter