Extract a range of tables from word document-CodePudding

My Word document has 50 tables in it, i need to know how can i extract the table number 20 to table number 30 from the word document. Currently the code i am using is extracting all tables from the word document. Also, if possible could we allow the user to input the range when the script is run ?

 Option Explicit

Sub ImportWordTables()

    Dim wd As Word.Application
    Dim doc As Word.Document
    Dim tbl As Word.Table
    Dim ws As Worksheet
    Set wd = New Word.Application
    wd.Visible = True
    
    Set doc = wd.Documents.Open(ThisWorkbook.Path & "\fivetables.docx")
    
    For Each tbl In doc.Tables
    
        tbl.Range.Copy
        Set ws = ThisWorkbook.Worksheets.Add
        ws.PasteSpecial "HTML"
        ws.Range("A1").CurrentRegion.EntireColumn.AutoFit
        
    Next tbl
    
    doc.Close
    wd.Quit
    
End Sub

CodePudding user response：

For example:

Sub ImportWordTables()
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim xlWkSht As Worksheet, i As Long, j As Long, t As Long
With wdApp
  .Visible = False
  Set wdDoc = .Documents.Add '.Open(ActiveWorkbook.Path & "\fivetables.docx")
  With wdDoc
    t = .Tables.Count
    i = CLng(InputBox("The document has " & t & " tables." & vbCr & _
        "Table to start at?"))
    If i < 1 Then GoTo ErrExit
    If i > t Then GoTo ErrExit
    j = CLng(InputBox("The document has " & t & " tables." & vbCr & _
        "Table to end at?"))
    If j > t Then j = t
    For t = i To j
      .Tables(t).Range.Copy
      Set xlWkSht = ActiveWorkbook.Worksheets.Add
      xlWkSht.PasteSpecial "HTML"
      xlWkSht.Range("A1").CurrentRegion.EntireColumn.AutoFit
    Next
ErrExit:
    .Close False
  End With
  .Quit
End With
Application.ScreenUpdating = True
End Sub

CodePudding user response：

The basic answer to your question is to use the Item-property of the Tables-Collection to retrieve the specified range of tables

I would split the code into four parts:

main routine (importWordTables)
sub to get the user input for the table indeces getTableIndeces
sub that checks input for valid data and raises errors if the input isn't correct checkValidIndexInput
sub to import the tables specified by user importWordTablesFromTo.
last but not least I am using a function to get the WordApp - which returns the current instance of word if open otherwise opens word. getWordApp

Public Sub importWordTables()

On Error GoTo err_Import

    Dim wd As Word.Application
    Dim doc As Word.Document
    
    Set wd = getWordApp
    
    'Set doc = wd.Documents.Open(ThisWorkbook.Path & "\fivetables.docx")
        
    Dim iFrom As Long, iTo As Long
    
    getTableIndeces doc, iFrom, iTo
    
    importWordTablesFromTo doc, iFrom, iTo
    
    doc.Close
    
exit_Import:
    If Not doc Is Nothing Then doc.Close
    Exit Sub
    
err_Import:
    MsgBox Err.Description, vbCritical
    Resume exit_Import

End Sub

To get and check table indeces:

Private Sub getTableIndeces(doc As Word.Document, ByRef iFrom As Long, ByRef iTo As Long)

Dim cntTables As Long
cntTables = doc.Tables.Count

Dim varFrom As Variant, varTo As Long

varFrom = InputBox("Index of first table to be imported (no of tables: " & cntTables & ")", "Import tables: first table", 1)
checkValidIndexInput varFrom, cntTables

iFrom = varFrom


varTo = InputBox("Index of last table to be imported (no of tables: " & cntTables & ")", "Import tables: last table", cntTables)
checkValidIndexInput varTo, cntTables, iFrom
iTo = varTo


End Sub

Private Sub checkValidIndexInput(ByVal varIndex As Variant, ByVal cntTables As Long, Optional iFrom As Long)
If Not IsNumeric(varIndex) Then 'not a number
    Err.Raise vbObjectError, , "Please enter a valid number as index."
    
ElseIf varIndex < 0 Or varIndex > cntTables Then  'not within range
    Err.Raise vbObjectError, , "Index of the table has to be between 1 and " & cntTables & "."

ElseIf iFrom > 0 And varIndex < iFrom Then
    Err.Raise vbObjectError, , "Index of last table has to be greater than index of first table (" & iFrom & ")."
End If
End Sub

Writing the selected table range to the current workbook:

Sub importWordTablesFromTo(doc As Word.Document, iFrom As Long, iTo As Long)

    Dim i As Long, tbl As Word.Table, ws As Worksheet
    
    For i = iFrom To iTo   
        Set tbl = doc.Tables.Item(i)     '---> retrieve the specified table
        
        tbl.Range.Copy
        Set ws = ThisWorkbook.Worksheets.Add
        ws.PasteSpecial "HTML"
        ws.Range("A1").CurrentRegion.EntireColumn.AutoFit
        
    Next
       
End Sub

To retrieve the current or a new word instance:

Private Function getWordApp() As Word.Application

Dim WordApp As Word.Application

On Error Resume Next    'in case Word isn't already open
Set WordApp = GetObject(, "Word.Application")
If Err > 0 Or WordApp Is Nothing Then
    Set WordApp = CreateObject("Word.Application")
End If

WordApp.Visible = True

Set getWordApp = WordApp
End Function