# Extract Table from Word After Locating the Non-Table Content Above That Table VBA



## ChrisOK (Jan 26, 2017)

I've got code that will extract all Tables from a Word doc.. fantastic!
I've got code that will extract all NON-table content from a Word doc... also fantastic!
I've got code that will use a msg box to go seek out a word or phrase and then extract in the whole row.. again great!

*But now I've encountered a scenario where a Table within a Word doc needs to be extracted -- however, it's Table Name is in regular verbiage (above) and outside the table... Go figure... Grrrr ...*

I'm hoping there's a way to combine these 2 sets of code that work beautifully to be able to do this:
1=Enter the word/phrase I want sought out ---
2=Once a 'hit' is found -- it will copy/paste/extract that table into a specified Worksheet called: "RESULTS" within the 'Active Workbook' that I would have open --- that would initiate the code..

*HERE'S THE CODE THAT USES A SEARCH FEATURE:*

```
Public Sub FindMultipleSheet****s()
'
'loops through all the sheets within a workbook (except the one you tell it NOT to touch) because
'that one is reserved for pasting findings to it...
'
'Run from standard module, like: Module1.
 'Find all data on all sheets!
 'Do not search the sheet the found data is copied to!
 'List a message box with all the found data addresses, as well!
 Dim ws As Worksheet, Found As Range
 Dim myText As String, firstAddress As String
 Dim AddressStr As String, foundNum As Integer

 myText = InputBox("Enter text to find")

If myText = "" Then Exit Sub

For Each ws In ThisWorkbook.Worksheets
With ws
'Do not search sheet25!=== ENTER NAME OF SHEET THAT YOU DO NOT WANT SEARCHED===
If ws.Name = "MASTER" Then GoTo myNext

Set Found = .UsedRange.Find(what:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

If Not Found Is Nothing Then
firstAddress = Found.Address

Do
foundNum = foundNum + 1
 AddressStr = AddressStr & .Name & " " & Found.Address & vbCrLf

Set Found = .UsedRange.FindNext(Found)

'Copy found data row to sheet4 Option! === ENTER NAME OF SHEET WHERE YOU WANT RESULTS PLACED===
'IT WILL LOCATE THE UNIQUE WORD OR PHRASE AND EXTRACT EVERYTHING ON THE WHOLE ROW
'this is very helpful to be able to see if this is valid content wanted or not
'IT ALSO WILL PROVIDE A MSG BOX SHOWING EXACT LOCATION OF ALL HITS
 Found.EntireRow.Copy _
 Destination:=Worksheets("RESULTS").Range("A65536").End(xlUp).Offset(1, 0)
Loop While Not Found Is Nothing And Found.Address <> firstAddress
End If

myNext:
End With

Next ws

If Len(AddressStr) Then
MsgBox "Found: """ & myText & """ " & foundNum & " times." & vbCr & _
 AddressStr, vbOKOnly, myText & " found in these cells"
 Else:

 MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
End Sub
```

*HERE'S THE CODE THAT EXTRACTS ALL TABLES OUT OF A WORD DOC (.DOC or .DOCX) -ability to edit in code as needed:*
_(I only want the table that's found immediately beneath the search phrase -- in this case, not ALL tables)_

```
Sub ImportWordTableDOC()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Long 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Long 'column index in Excel
Dim resultRow As Long
Dim tableStart As Long
Dim tableTot As Long
Dim wkSht As Worksheet

On Error Resume Next

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)
  Set wkSht = ActiveSheet
  wkSht.Range("A:AZ").ClearContents

  Set wdDoc = GetObject(wdFileName) 'open Word file

  With wdDoc
    tableNo = wdDoc.Tables.Count
    tableTot = wdDoc.Tables.Count
    If tableNo = 0 Then
      MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
      tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If

    resultRow = 4

    For tableStart = 1 To tableTot
      With .Tables(tableStart)
        'copy cell contents from Word table cells to Excel cells
        For iRow = 1 To .Rows.Count
          For iCol = 1 To .Columns.Count
            wkSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
          Next iCol
          resultRow = resultRow + 1
        Next iRow
      End With
      resultRow = resultRow + 1
      With wkSht
        .Range(.Cells(resultRow, 1), .Cells(resultRow, iCol)).Interior.ColorIndex = 15
      End With
      resultRow = resultRow + 1
    Next tableStart
End With

End Sub
```

In advance, thank you - I know there's a brilliant mind out there that knows how to combine something like this..


----------



## Worf (Jan 28, 2017)

The following code will:

·         Find the string typed by user on the Word document
·         Create an index for each Word table, based on its position
·         Build an Excel range with Word table information
·         Find the desired table number on the range
·         Copy that table from Word to Excel


```
' Excel module
Sub FindTable()
Dim i%, j%, ow, mydoc As Document, mytext$, spos, lr$, tn%
Set ow = GetObject(, "Word.Application")
ow.Visible = True
Set mydoc = ow.ActiveDocument
mytext = InputBox("Enter text to find")
ow.Selection.HomeKey wdStory
ow.Selection.Find.ClearFormatting
With ow.Selection.Find
    .ClearFormatting
    .Text = mytext
    .Forward = True
    .Wrap = wdFindStop
    .Execute                                                            ' find string
End With
ow.Selection.HomeKey wdLine
spos = CStr(ow.Selection.Information(wdActiveEndPageNumber) + _
(ow.Selection.Information(wdFirstCharacterLineNumber) / 100))           ' string position index
spos = Replace(spos, ",", ".")
If mytext = "" Then Exit Sub
Sheets("sheet4").Activate
[a:b].ClearContents
For i = 1 To mydoc.Tables.Count
    mydoc.Tables(i).cell(1, 1).Select
    Cells(i, 1) = ow.Selection.Information(wdActiveEndPageNumber) + _
    (ow.Selection.Information(wdFirstCharacterLineNumber) / 100)        ' table position index
    Cells(i, 2) = i                                                     ' table number
Next
Sorter Sheets("sheet4"), [a1].CurrentRegion                             ' sort table information
lr = CStr(Range("a" & Rows.Count).End(xlUp).Row)
tn = Cells(Evaluate("=match(vlookup(" & spos & ",a1:b" & lr & ",2,true),b1:b" & lr & ",0)+1"), 2)
Sheets("results").Activate
For i = 1 To mydoc.Tables(tn).Rows.Count                                ' import desired table
    For j = 1 To mydoc.Tables(tn).Columns.Count
        Cells(i, j) = WorksheetFunction.Clean(mydoc.Tables(tn).cell(i, j).Range.Text)
    Next
Next
Set mydoc = Nothing
Set ow = Nothing
MsgBox "end of code"
End Sub


Sub Sorter(ws As Worksheet, r As Range)
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add ws.[a1], xlSortOnValues, xlAscending, , xlSortNormal
With ws.Sort
    .SetRange r
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlStroke
    .Apply
End With
End Sub
```


----------



## ChrisOK (Jan 30, 2017)

Thank you Worf for the input -- I'm having trouble getting it to work -- Do I paste the whole thing into "ThisWorkbook" area? Or should one of the subs be pasted into a separate module? 
I pasted it all into then hit run - It generated the input field msgbox, I typed in something to search and it returned: 
*"Run-time error 9:  Subscript out of range"?*
_(the cursor stops/is flashing on this line - between the C and the Str):_
*spos = CStr(ow.Selection.Information(wdActiveEndPageNumber) + _*

I noticed further down there was refc of "Sheet 4" and my workbook only had Sheet 1 present, I so went ahead and clicked the "+" to add Sheets 2, 3, & 4 to see if that helped matters...
Re-ran and this time, I got a different error.. 
*"Run-time error 13 - Type mismatch --*

???

Any ideas what might be going wrong?
Thank you, C


----------



## Worf (Jan 30, 2017)

-      Paste the code into a standard module (Module1, Module2...)
-      The code assumes that the Word document is already opened.
-      The necessary information table is generated at Sheet4, but you may change that.
-      A sheet named Results is also required.
-      The code currently does not perform error checking on the Word find method, so make sure you type something that is above and outside a table on that document. We can refine this later after it is working on your end.
-      Please test again and report eventual errors mentioning line and error message.


----------



## Macropod (Jan 31, 2017)

Here's some simpler code for you to adapt. It takes the document name & table name as arguments.

```
Sub GetMiscTable(strDocNm As String, strTblNm As String)
Dim r As Long, xlWkSht As Worksheet
If strTblNm = "" Then Exit Sub
Set xlWkSht = ActiveWorkbook.Worksheets("RESULTS")
r = xlWkSht.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
With wdApp
  Set wdDoc = .Documents.Open(strDocNm)
  With wdDoc
    For Each wdTbl In .Tables
      With wdTbl.Range
        If InStr(.Characters.First.Previous.Paragraphs.First.Range.Text, strTblNm) = 1 Then
          .Copy: xlWkSht.Paste Destination:=Range("A" & r): Exit For
        End If
      End With
    Next
    .Close False
  End With
  .Quit
End With
Set wdTbl = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing: Set xlWkSht = Nothing
End Sub
```
The code could be run from a standard module, a sheet module, workbook module, userform, or a standard module - just add it to whatever module you want to call it from.

PS: When posting questions whose scope includes applications other than Excel, you should post in: General Excel Discussion & Other Questions


----------



## ChrisOK (Jan 31, 2017)

WORF: Thanks for expanding - I moved the first sub to Mod1 and the smaller one to Mod 2, 
Opened a Word doc (which I did not have done prior -- not realizing it was necessary) --
NOW it works great! -- The table is extracted and placed on the "RESULTS" tab - however,
*Can you tell me what the output is that has appeared on "Sheet 4"?*
It looks like this:  (it is a time clock/tracking of speed of code perhaps?)
1.12	1
2.03	2
3.03	3
4.03	4
7.02	5
7.22	6
8.03	7

Thank you very much for your help! - This is a huge help to that problem where the NAME of the table was outside the table..


----------



## ChrisOK (Jan 31, 2017)

MACROPOD:
knowing from experience --- this has got to be something awesome as well -- but I'm not able to get it working..
=-/
Using the same test file, I created a 3rd module: "Module 3" and pasted in your code.
Created a new sheet called "RESULTS"
Hit run --but it does not find the code in the list to run it --
(the only thing that appears to select is the code that's sitting in Module 1 within this workbook that WORF suggested)
I checked to make sure the full paste was there... saved.... verified all the Tool>Refcs were check-marked (yes, _I've learned lessons from the past)_ lol --
So -- why is Module 3's code not appearing as an option to pick to run...?

PS - I (did) post this in the 'Gen Excel Disc & Other Questions' area - so I'm not sure what I did wrong?


----------



## Macropod (Jan 31, 2017)

ChrisOK said:


> Using the same test file, I created a 3rd module: "Module 3" and pasted in your code.
> Created a new sheet called "RESULTS"
> Hit run --but it does not find the code in the list to run it --
> (the only thing that appears to select is the code that's sitting in Module 1 within this workbook that WORF suggested)


Compare that with:


> The code could be run from a standard module, a sheet module, workbook module, userform, or a standard module - _just add it to whatever module you want to call it from_.





ChrisOK said:


> PS - I (did) post this in the 'Gen Excel Disc & Other Questions' area - so I'm not sure what I did wrong?


No, I moved it here from 'Excel Questions' - just like I did with your other automation threads...


----------



## ChrisOK (Jan 31, 2017)

oh-- ok Macropod - didn't realize it was to be added to an existing module ---
assumed it needed to go into a nice clean Standard Module of its own --

Sorry-- didn't realized you'd moved them -- 
I'll make note -- thanks for the heads up --



Macropod said:


> Compare that with:
> 
> 
> No, I moved it here from 'Excel Questions' - just like I did with your other automation threads...


----------



## ChrisOK (Feb 1, 2017)

*Having a problem:*
The code has been running great on the .DOCX files - but won't work on the .DOC files..
I looked for references of "docx" to be able to change the extension in the code - but am not seeing it...
Is there a toggle number perhaps that I need to change  -- like from "1" to "2" to make it run on .DOC file types?


----------



## ChrisOK (Jan 26, 2017)

I've got code that will extract all Tables from a Word doc.. fantastic!
I've got code that will extract all NON-table content from a Word doc... also fantastic!
I've got code that will use a msg box to go seek out a word or phrase and then extract in the whole row.. again great!

*But now I've encountered a scenario where a Table within a Word doc needs to be extracted -- however, it's Table Name is in regular verbiage (above) and outside the table... Go figure... Grrrr ...*

I'm hoping there's a way to combine these 2 sets of code that work beautifully to be able to do this:
1=Enter the word/phrase I want sought out ---
2=Once a 'hit' is found -- it will copy/paste/extract that table into a specified Worksheet called: "RESULTS" within the 'Active Workbook' that I would have open --- that would initiate the code..

*HERE'S THE CODE THAT USES A SEARCH FEATURE:*

```
Public Sub FindMultipleSheet****s()
'
'loops through all the sheets within a workbook (except the one you tell it NOT to touch) because
'that one is reserved for pasting findings to it...
'
'Run from standard module, like: Module1.
 'Find all data on all sheets!
 'Do not search the sheet the found data is copied to!
 'List a message box with all the found data addresses, as well!
 Dim ws As Worksheet, Found As Range
 Dim myText As String, firstAddress As String
 Dim AddressStr As String, foundNum As Integer

 myText = InputBox("Enter text to find")

If myText = "" Then Exit Sub

For Each ws In ThisWorkbook.Worksheets
With ws
'Do not search sheet25!=== ENTER NAME OF SHEET THAT YOU DO NOT WANT SEARCHED===
If ws.Name = "MASTER" Then GoTo myNext

Set Found = .UsedRange.Find(what:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

If Not Found Is Nothing Then
firstAddress = Found.Address

Do
foundNum = foundNum + 1
 AddressStr = AddressStr & .Name & " " & Found.Address & vbCrLf

Set Found = .UsedRange.FindNext(Found)

'Copy found data row to sheet4 Option! === ENTER NAME OF SHEET WHERE YOU WANT RESULTS PLACED===
'IT WILL LOCATE THE UNIQUE WORD OR PHRASE AND EXTRACT EVERYTHING ON THE WHOLE ROW
'this is very helpful to be able to see if this is valid content wanted or not
'IT ALSO WILL PROVIDE A MSG BOX SHOWING EXACT LOCATION OF ALL HITS
 Found.EntireRow.Copy _
 Destination:=Worksheets("RESULTS").Range("A65536").End(xlUp).Offset(1, 0)
Loop While Not Found Is Nothing And Found.Address <> firstAddress
End If

myNext:
End With

Next ws

If Len(AddressStr) Then
MsgBox "Found: """ & myText & """ " & foundNum & " times." & vbCr & _
 AddressStr, vbOKOnly, myText & " found in these cells"
 Else:

 MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
End Sub
```

*HERE'S THE CODE THAT EXTRACTS ALL TABLES OUT OF A WORD DOC (.DOC or .DOCX) -ability to edit in code as needed:*
_(I only want the table that's found immediately beneath the search phrase -- in this case, not ALL tables)_

```
Sub ImportWordTableDOC()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Long 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Long 'column index in Excel
Dim resultRow As Long
Dim tableStart As Long
Dim tableTot As Long
Dim wkSht As Worksheet

On Error Resume Next

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)
  Set wkSht = ActiveSheet
  wkSht.Range("A:AZ").ClearContents

  Set wdDoc = GetObject(wdFileName) 'open Word file

  With wdDoc
    tableNo = wdDoc.Tables.Count
    tableTot = wdDoc.Tables.Count
    If tableNo = 0 Then
      MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
      tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If

    resultRow = 4

    For tableStart = 1 To tableTot
      With .Tables(tableStart)
        'copy cell contents from Word table cells to Excel cells
        For iRow = 1 To .Rows.Count
          For iCol = 1 To .Columns.Count
            wkSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
          Next iCol
          resultRow = resultRow + 1
        Next iRow
      End With
      resultRow = resultRow + 1
      With wkSht
        .Range(.Cells(resultRow, 1), .Cells(resultRow, iCol)).Interior.ColorIndex = 15
      End With
      resultRow = resultRow + 1
    Next tableStart
End With

End Sub
```

In advance, thank you - I know there's a brilliant mind out there that knows how to combine something like this..


----------



## ChrisOK (Feb 1, 2017)

Here's what happens when I try to run it on the .doc files: 
(but it never has any probs with the .docx files)
The code crashes at this point -- and the bolded line below is the one that's highlighted in yellow...
*tn = Cells(Evaluate("=match(vlookup(" & spos & ",a1:b" & lr & ",2,true),b1:b" & lr & ",0)+1"), 2)
*
With error: "Run-time error 13 - Type mismatch"


```
Next
Sorter Sheets("Sheet2"), [a1].CurrentRegion                             ' sort table information
lr = CStr(Range("a" & Rows.Count).End(xlUp).Row)
tn = Cells(Evaluate("=match(vlookup(" & spos & ",a1:b" & lr & ",2,true),b1:b" & lr & ",0)+1"), 2)
```


----------



## ChrisOK (Feb 2, 2017)

Problem:
The code works w/ DOCX files but won't work w/ .DOC files, is there a way to adjust it to make it work on both ---or at least have the ability to switch it back and forth within the code when working with large batches of each file type?

I didn't see any refcs of file types within the code, so I'm not sure where it would be adjusted?

I'm getting a Run time error 13 - Type Mismatch ---and the following line is what's highlighted in yellow - which led me to believe maybe changing a 1,2 setting might toggle it between working on docx vs doc files?

```
tn = Cells(Evaluate("=match(vlookup(" & spos & ",a1:b" & lr & ",2,true),b1:b" & lr & ",0)+1"), 2)
```

Hope someone knows how to resolve this problem?


----------



## Worf (Feb 3, 2017)

I am not sure the problem is the file format.
When the yellow line appears, please place the mouse over the variables “spos” and “lr”, this will show their values. Post back the values so I can analyze them.


----------



## Worf (Feb 9, 2017)

This version:

-      Checks if the desired string is present at the Word document
-      Eliminates an unnecessary loop


```
Sub FindTable()
Dim i%, j%, ow, mydoc As Document, mytext$, spos, lr$, tn%, wr As Word.Range
Set ow = GetObject(, "Word.Application")
ow.Visible = True
Set mydoc = ow.ActiveDocument
mytext = InputBox("Enter text to find")
Set wr = mydoc.Content
wr.Find.Execute mytext, , , , , , True
If wr.Find.Found = False Or mytext = "" Then
    MsgBox "Text not found!", vbCritical, mytext
    Exit Sub
End If
ow.Selection.HomeKey wdStory
ow.Selection.Find.ClearFormatting
With ow.Selection.Find
    .ClearFormatting
    .Text = mytext
    .Forward = True
    .Wrap = wdFindStop
    .Execute                                                            ' find string
End With
ow.Selection.HomeKey wdLine
spos = CStr(ow.Selection.Information(wdActiveEndPageNumber) + _
(ow.Selection.Information(wdFirstCharacterLineNumber) / 100))           ' string position index
spos = Replace(spos, ",", ".")
Sheets("sheet4").Activate
[a:b].ClearContents
For i = 1 To mydoc.Tables.Count
    mydoc.Tables(i).cell(1, 1).Select
    Cells(i, 1) = ow.Selection.Information(3) + _
    (ow.Selection.Information(10) / 100)                                ' table position index
    Cells(i, 2) = i                                                     ' table number
Next
Sorter Sheets("sheet4"), [a1].CurrentRegion                             ' sort table information
lr = CStr(Range("a" & Rows.Count).End(xlUp).Row)
tn = Cells(Evaluate("=match(vlookup(" & spos & ",a1:b" & lr & ",2,true),b1:b" & lr & ",0)+1"), 2)
mydoc.Tables(tn).Range.Copy
Sheets("results").Paste Destination:=Sheets("results").[a1]
Set mydoc = Nothing
Set ow = Nothing
MsgBox "end of code"
End Sub
```


----------

