To find word in Microsoft Word Table and copy Offsets to Excel Cells

[johngalvin]

Hello
Is it possible to use Excel VBA on a Word Document, and after finding a table in that Word Document to search within that table (in its cells) for a word and copy some cells (Offsets) from the same column, but lower rows (like the Excel Offset) to Excel? Or to find the cell and copy its offset from the next column to Excel? In short can VBA Excel look for a word in a cell within a Word Table and get the offsets near it (below in or from next column) to be copied to Excel?

Has anyone tried this? I know how to do it from Excel -> Excel but don't know how to do Word->Excel

If it's possible I would really be grateful if someone could give an example of how to find a cell in a word table and then copy the cell from next column or the cell from the row below.


For example if there is a Table in a Word Document like this

Fruits Quantity
Apples 5
Pears 2
Oranges 8

Is it possible to look using an Excel VBA into the Word Document Table for "Fruits" and if fruits is found to copy Apples to Excel on A1? Or, alternatively to search for Apples within the Table and to copy 5 on B1 in Excel


Many thanks
John

[Dave]

John it's very similar logic to the last post. You can trial this (it's still set up for multi-files)...

Option Explicit
Sub XLWordTable()
Dim WrdApp As Object, Cnt As Integer, FileStr As String
Dim WrdDoc As Object, TblCell As Variant, SearchWord As String
Dim FSO As Object, FolDir As Object, FileNm As Object
'*** SearchWord is case sensitive
SearchWord = "Fruits"
On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False
Set FSO = CreateObject("scripting.filesystemobject")
'***change directory to suit
Set FolDir = FSO.GetFolder("D:\testfolder")
'loop files
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".docx" Then
FileStr = CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.tables.Count < 1 Then
GoTo Below
End If
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.tables.Count
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.tables(Cnt).Range.Cells
If InStr(TblCell.Range, SearchWord) Then
Sheets("sheet1").Range("A" & 1) = WrdApp.ActiveDocument.tables(Cnt).Cell(TblCell.RowIndex + 1, TblCell.ColumnIndex)
'remove pilcrow
Sheets("sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("sheet1").Range("A" & 1))
Sheets("sheet1").Range("B" & 1) = WrdApp.ActiveDocument.tables(Cnt).Cell(TblCell.RowIndex + 1, TblCell.ColumnIndex + 1)
Sheets("sheet1").Range("B" & 1) = Application.WorksheetFunction.Clean(Sheets("sheet1").Range("B" & 1))
'WrdApp.ActiveDocument.Tables(Cnt).Delete
GoTo Below
End If
Next TblCell
Next Cnt
Below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
End If
Next FileNm
Set FolDir = Nothing
Set FSO = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
Set FolDir = Nothing
Set FSO = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

[johngalvin]

Hey Dave !
Thank you so much for your input ! That was brilliant, and works like charm!

The last thing, I tried stopping at the 1st encountered table after the word search rather than looping but it sort of doesen't work, I've attached the code below

Many thanks,
John

Tried Something new as you can see below, yields the Error "The file appears to be corrupted"


Option Explicit
Sub XLWordTables()
Dim WrdApp As Object, Cnt As Integer, FileStr As String
Dim WrdDoc As Object, TblCell As Variant, SearchWord As String
Dim FSO As Object, FolDir As Object, FileNm As Object
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False
Set FSO = CreateObject("scripting.filesystemobject")
'***change directory to suit
Set FolDir = FSO.GetFolder("C:\Users\John\Desktop\Studio")
'loop files
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".docx" Then
FileStr = CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
Dim TableRange As Word.Range
Const WholeContent As Integer = 1
With WrdDoc.StoryRanges(WholeContent)
With .Find
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindContinue
.Text = "Solo"
.Execute
End With
Set TableRange = .Duplicate.Next(unit:=wdTable)
With TableRange.Tables(1)
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
Sheets("WM").Range("A" & 8) = WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1)
'remove pilcrow
Sheets("WM").Range("A" & 8) = Application.WorksheetFunction.Clean(Sheets("WM").Range("A" & 8))
Next TblCell
End With
End With
End If
Next
End Sub

[johngalvin]

Hey Dave !
Thank you so much for your input ! That was brilliant, and works like charm!

The last thing, I tried stopping at the 1st encountered table after finding the WordSearch rather than looping the tables, but it sort of doesen't work, I've attached the code below

Many thanks,
John

Tried Something new as you can see below, yields the Error "The file appears to be corrupted"


Option Explicit
Sub XLWordTables()
Dim WrdApp As Object, Cnt As Integer, FileStr As String
Dim WrdDoc As Object, TblCell As Variant, SearchWord As String
Dim FSO As Object, FolDir As Object, FileNm As Object
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False
Set FSO = CreateObject("scripting.filesystemobject")
'***change directory to suit
Set FolDir = FSO.GetFolder("C:\Users\John\Desktop\Studio")
'loop files
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".docx" Then
FileStr = CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
Dim TableRange As Word.Range
Const WholeContent As Integer = 1
With WrdDoc.StoryRanges(WholeContent)
With .Find
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindContinue
.Text = "Solo"
.Execute
End With
Set TableRange = .Duplicate.Next(unit:=wdTable)
With TableRange.Tables(1)
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
Sheets("Sheet1").Range("A" & 1) = WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1)
'remove pilcrow
Sheets("Sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("Sheet1").Range("A" & 1))
Next TblCell
End With
End With
End If
Next
End Sub


Ahh I realized that this code (above) will try to get the next table which is wrong (should grab current table), so please ignore the above post (#3). I tried editing a bit the code to stop at the 1st encountered table after the SearchWord was found (rather than doing the table loop and stopping and last encountered table), below is the Code that I tried, but it won't fill the Cell in Excel. Your input would be greatly appreciated. Many thanks ! John



Option Compare Text'<To stop Case sensitivity
Dim SearchWord As String
'SearchWord is case sensitive
SearchWord = "Solo"
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo Below
End If
If InStr(TblCell.Range, SearchWord) Then
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
Sheets("Sheet1").Range("A" & 1) = WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1)
Sheets("Sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("Sheet1").Range("A" & 1))
Next TblCell
End If
End Sub

[Dave]

John I don't understand. The code exits after it does only 1 table and then moves on to the next document? (See the "Goto Below" code) Dave

[johngalvin]

Hi Dave.
Yes to your question. It searches the document for the SearchWord and when found it gets the 1st encountered table , it doesen't have to loop through all the tables and end up with the last encountered one.

For example if in the Word Document we are searching (SearchWord) for "Solo" it should go to the 1st table where "Solo" appears, get the next column near it and put it in Cell A1 Excel. It shouldn't loop all tables and end up to go to the last table where "Solo" appears.

Many thanks
John

[Dave]

Again John it doesn't loop any tables after it finds the table with the search word... it moves to the next file and again places the information in the same place (A1& B1) ie. there is no code to capture info from multiple files. The code was only to show U the "how to" and it seemed the code from your previous post was handy for adjustment. I'm guessing this is the actual problem. Dave

[johngalvin]

Hello Dave

Speaking of a single Word Document file.
There are multiple tables within a Word Document file that include the same SearchWord and I noticed that it just copied the next column to A1 from the last table in which the SearchWord appeared, and not from the 1st one, and that's why I tried to adjust it. I don't need it to capture from multiple files. One file is enough for this, but I have to make it to take from the 1st encountered table after the SearchWord was found and not to loop until the last table within the same File. Do you think something can be done about that?

Best,
John

[Dave]

U can trial this. Change the file address to suit. Dave

Option Explicit
Sub XLWordTable()
Dim WrdApp As Object, Cnt As Integer, FileStr As String
Dim WrdDoc As Object, TblCell As Variant, SearchWord As String
Dim FSO As Object, FolDir As Object, FileNm As Object
'SearchWord is case sensitive
SearchWord = "Fruits"
'On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False
'Set FSO = CreateObject("scripting.filesystemobject")
'change directory to suit
'Set FolDir = FSO.GetFolder("D:\testfolder")
'loop files
'For Each FileNm In FolDir.Files
'If FileNm.Name Like "*" & ".docx" Then
'FileStr = CStr(FileNm)
'change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.tables.Count < 1 Then
GoTo Below
End If
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.tables.Count
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.tables(Cnt).Range.Cells
If InStr(TblCell.Range, SearchWord) Then
Sheets("sheet1").Range("A" & 1) = WrdApp.ActiveDocument.tables(Cnt).Cell(TblCell.RowIndex + 1, TblCell.ColumnIndex)
'remove pilcrow
Sheets("sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("sheet1").Range("A" & 1))
Sheets("sheet1").Range("B" & 1) = WrdApp.ActiveDocument.tables(Cnt).Cell(TblCell.RowIndex + 1, TblCell.ColumnIndex + 1)
Sheets("sheet1").Range("B" & 1) = Application.WorksheetFunction.Clean(Sheets("sheet1").Range("B" & 1))
'WrdApp.ActiveDocument.Tables(Cnt).Delete
GoTo Below
End If
Next TblCell
Next Cnt
Below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
'End If
'Next FileNm
'Set FolDir = Nothing
'Set FSO = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
'Set FolDir = Nothing
'Set FSO = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

[johngalvin]

That's perfect, Dave ! Thank you, works like charm. I guess the thread can be marked as Solved now.

Many thanks!

[Dave]

You are again welcome John. Have a nice day. Dave
ps. U the thread starter marks them as solved

[johngalvin]

Hey guys
The problem is sort of solved, but can anyone please help out with copying directly the field from the Word Document( from the next column from the Word Table )without the Pilcrow symbol to Excel Cell? At the moment it is copying the field from the Word Table with a Pilcrow symbol to Excel, then it deletes it. Is there any way to copy directly without symbol (pilcrow)?



Option Explicit

Sub WordTabletoExcel()
Dim WrdApp AsObject, Cnt AsInteger, FileStr AsString
Dim WrdDoc AsObject, TblCell AsVariant
Dim FSO AsObject, FolDir AsObject, FileNm AsObject
OnErrorGoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible =False
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder("C:\Users\John\Desktop\Fruits")
'loop files
ForEach FileNm In FolDir.Files
If FileNm.Name Like"*"&".docx"Then
FileStr =CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count <1Then
GoTo Below
End If
Dim SearchWord AsString
SearchWord ="Fruits"
For Cnt =1To WrdApp.ActiveDocument.Tables.Count
'loop through table cells
ForEach TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
If InStr(TblCell.Range, SearchWord)Then
'remove pilcrow
Sheets(Sheet1").Range("A" & 1) = WrdApp.ActiveDocument.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1)
Sheets("Sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("Sheet1").Range("A" & 1))
End If
Next TblCell
Next Cnt
End Sub

This is how it is currently copying
https://imgur.com/Mbtw5Iz (https://imgur.com/a/lcJAod3)
And after a while it deletes that symbol

Was wondering if it could copy directly from Word table to Excel Cell without involving symbol and then deleting it.


Many thanks

John

[macropod]

Try:

Sheets(Sheet1").Range("A" & 1) = Split(WrdDoc.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1), vbCr, 0)

[johngalvin]

Hello Paul
That was quick, thanks!
I tried what you've suggested, the cell remains blank unfortunately.
This is now the code:


Dim SearchWord As String
SearchWord = "Fruits"
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
If InStr(TblCell.Range, SearchWord) Then
Sheets("Sheet1").Range("A" & 1) = Split(WrdDoc.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1), vbCr, 0)
Sheets("Sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("Sheet1").Range("A" & 1))
End If
Next TblCell
Next Cnt


The issue is that now it doesen't fill anymore the Cell A1, with anything. It used to put there the text with the symbol at the end and then delete the symbol after like 5-10 seconds or so, but it could be better if this could be done in 1 step, directly putting the text into cell without symbol and without the need to delete the symbol

John

[macropod]

Well, unless your Word cell has an empty paragraph at the start, there should be some output. You also don't need:

Sheets("Sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("Sheet1").Range("A" & 1))

[johngalvin]

Hello Paul,

Thanks for your message.

I adapted the code as following:
Unfortunately the cell A1 remains blank, so no Output, looked for sensitiveness of the text and of the code, all seems fine. I even tried on other Excel cell, but still blank. Even created a New Word Document in which I typed some random text then the Table in which I put the SearchWord "Fruits", and on the next Column "Apples", but still the cell remained blank, no output.


Dim SearchWord As String
SearchWord = "Fruits"
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
If InStr(TblCell.Range, SearchWord) Then
Sheets("Sheet1").Range("A" & 1) = Split(WrdDoc.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1), vbCr, 0)
End If
Next TblCell
Next Cnt


If I put back the outdated code, the cell A1 would be filled with Apples[Symbol] and after like 10 seconds the [Symbol] would disappear, but there must be a way to do it in 1 step such as copying the text directly without Symbol


Dim SearchWord AsString
SearchWord ="Fruits"
For Cnt =1To WrdApp.ActiveDocument.Tables.Count
'loop through table cells
ForEach TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
If InStr(TblCell.Range, SearchWord)Then
'remove pilcrow
Sheets(Sheet1").Range("A" & 1) = WrdApp.ActiveDocument.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1)
Sheets("Sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("Sheet1").Range("A" & 1))
End If
Next TblCell
Next Cnt

[macropod]

Try the following:

Sub GetTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
Dim strFolder As String, strFile As String, WkSht As Worksheet, c As Long, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkSht = ActiveSheet
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
r = r + 1: c = 1
WkSht.Cells(r, c).Value = Split(strFile, ".docx")(0)
With wdDoc
For Each wdTbl In .Tables
With wdTbl.Range
With .Find
.Text = "Fruits"
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = True Then
c = c + 1
WkSht.Cells(r, c).Value = Split(wdTbl.Cell(.Cells(1).RowIndex + 1, .Cells(1).ColumnIndex + 1).Range.Text, vbCr)(0)
End If
End With
Next
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
PS:

Split(WrdDoc.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1), vbCr, 0)
should have been

Split(WrdDoc.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1), vbCr)(0)

[johngalvin]

Hi Paul,


I activated Word 16 Reference from Tools, I pointed to the Folder where the Word Document (.docx) is, I ran it, but yields this: "Run time error '1004' Unable to set the Text property of the Range class", pointing to this line:

WkSht.Cells(r, c).Text = Split(strFile, ".docx")(0)
I tried changing from .Text to .Value, but it won't output anything

I guess I'm doing something wrong, I checked the .Text and seems to be fine though.

Other than that, indeed
Split(WrdDoc.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1), vbCr)(0) now fills in that Cell, but it still take some time like 10-15 seconds, like before, just that it doesen't display the symbol, so I guess the above code with .Text can be a bit faster?

Many thanks,
John

[macropod]

Try changing both instances of:

WkSht.Cells(r, c).Text
to:

WkSht.Cells(r, c).Value
Code in post 17 revised.

[johngalvin]

Hi Paul,

I tried with the updated code, and double checked that both instances to have .value instead of .text

The code says that is running, no errors, but unfortunately doesen't fill any cell in Excel, so no output.

Thank you!

Best,
John

[macropod]

It works for me... I suggest you check the cell relationships implied by post #1 - the code looks for 'Fruits' then retrieves whatever is one cell below and to the right of that.

[johngalvin]

Hello Paul,
Yes the .Text is correct I double checked that, the .Text is assigned correctly, and it appears in the Word Document (.docx) (In a Table), everything seems fine but the Excel remains blank. What cells should it fill ? I used the Code updated as in Post #17

Best,
John

[macropod]

You should get output with the filename in column A, then each table's result in columns B, C, etc. Each document's output starts on a new row. As written, the cells containg the output values must be one cell below and to the right of the cell containing 'Fruits' and must not contain any paragraph breaks before the one containing the output value.

[johngalvin]

Hey Paul

Thanks for your quick reply !

Basically I have these tables in a Word Document, and one of it has the Word "Fruits" in it, unfortunately it doesen't output anything in Excel. I was thinking of a code that would search within the Word Document find the "Fruits" within the table and get the next column to a specific given Excel Cell, sort of what Dave has done, but it would be more suitable if it could be faster (because with Dave's code it works, but it's like 10-15 seconds /cell)


This is an example of the Word Document:
25131

I tried to use Excel VBA to search for "Fruits" within the Word Document and it should output something like this (please note that I added the text there manually, in Excel as the VBA Code in post #17 won't output anything unfortunately)
25132

[macropod]

The document screenshot you posted is nothing like the table structure indicated in Post 1...

[johngalvin]

I tried with this table and unfortunately it didn't output, I don't get what I'm doing wrong
25133

25136

[macropod]

The attached demonstrates both the kind of source documents the code expects and the output. Indeed, if you extract the files and run the macro, you should get new rows with the same output.

[johngalvin]

Hey Paul !

Cool, cheers for the Demo. I get how it works now.
Can this code be adjusted to put a specific cell from the Table to a specific Cell in Excel, rather than inserting in Columns?

Here for example
25139
To look for "Apples" and return 5 into cell A1 in Excel?

I made it look for "Apples" in the 1st Word Document "Fruits1.docx", for the 1st Table, And this is the current Output:

25141
The question is: can the output Cell be set-up from the Excel VBA to a given Cell?

[macropod]

Most of what you want is as simple as -
1. Deleting:
WkSht.Cells(r, c).Value = Split(strFile, ".docx")(0)
2. Changing:
.Text = "Fruits"
to:
.Text = "Apples"
3. Changing:
.Cells(1).RowIndex + 1
to:
.Cells(1).RowIndex
Of course, the reason for capturing the filenames was so you could tell where the data originate.

As for writing to a particular cell, what that risks is simply overwriting the values, which doesn't seem particularly useful to me...

[johngalvin]

Hey Paul,

Yes, I've managed to change as you said, as it can be seen in post #28.
The only thing I need now is to output to a Specific Cell, any idea how this can be done?

Many thanks,
John

[macropod]

So you don't care if evey table in every document simply overwrites what's already there, leaving you with only the last returned value? If so, what's the point of using a macro to loop through all the tables in all the documents???

[johngalvin]

Hi Paul,

I do care, but what I'm trying to say is that it won't overwrite.
For Example, as above in Post #28 it can have a Table with a single "Apples" entry, so it finds it and puts the cell from the next column (value=5) in this case to Excel on Cell A1 say. Then, can look for another keyword that appears also once for example:"Oranges" and it can put the cell from the next column (value=2 let's say) in Excel on Cell A2 let's say, it won't overlap since the tables are not having same keywords.

Best,
John

[macropod]

And if you open 20 files containing 30 tables with the word 'apples', you'll end up with only the 'apples' value from the last table in the last document!!!!! All the rest will have been overwritten.

[johngalvin]

Yes, you are right here. But I also have 1 Word Document with Tables that don't have the same values in it, so it won't overwrite in the Excel. How should that output be done to fill in a specific Excel Cell? Can this be done?

Best,
John

[macropod]

If you only have one Word document, you really don't need code to go through a whole folder. Try:

Sub GetTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
Dim ArrFnd(), WkSht As Worksheet, i As Long
ArrFnd = Array("Apples", "Pears", "Oranges")
Set WkSht = ActiveSheet
With wdApp
With .Dialogs(wdDialogFileOpen)
.Name = "*.doc"
.ReadOnly = True
If .Show = -1 Then
Set wdDoc = wdApp.ActiveDocument
With wdDoc
For i = 0 To UBound(ArrFnd)
For Each wdTbl In .Tables
With wdTbl.Range
With .Find
.Text = ArrFnd(i)
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = True Then
WkSht.Range("B" & i + 2).Value = Split(wdTbl.Cell(.Cells(1).RowIndex, .Cells(1).ColumnIndex + 1).Range.Text, vbCr)(0)
Exit For
End If
End With
Next
Next
.Close SaveChanges:=False
End With
Else
MsgBox "No file selected. Exiting", vbExclamation
End If
End With
.Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

[johngalvin]

Hey Paul,

Cheers, that works exactly as suited for the 1 Document version.

Thank you both !(Also to Dave)

Best,
John

[johngalvin]

Paul,

Would the code run faster in terms of Filling in the Excel Cells if the For loop would be replaced with a With in a table range ?
It takes a bit, like few good minutes to fill in the Excel Cells, even if using Arrays, and the CPU is not bad, so was wondering if the fill-in speed could be adjusted to faster?

Cheers

Best,
John

[Dave]

John I see that Paul has provided you with some very nice code using an alternate approach. Your concern was the delay in removing the pilcrow. I think the delay is actually caused by the time it takes to close the doc and quit the Word App. U could trial adding some screen updating code so that U don't see the results with the pilcrow only the final output. HTH. Dave

[macropod]

Would the code run faster in terms of Filling in the Excel Cells if the For loop would be replaced with a With in a table range ?
Unlikely. Most of the time the macro takes to execute relates to creating the necessary Word session and opening the document. Once those overheads are dealt with, the rest of the code is very quick.

[johngalvin]

Hello,

Just for the sake of it, is there any possibility to make it find the exact SearchWord, or at least Case sensitive ?


Dim SearchWord As String

SearchWord = "Apple"


For Each wdTbl In .Tables
With wdTbl.Range
With .Find

.Text = SearchWord
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = True Then
WkSht.Range("A" & 1).Value = Split(wdTbl.Cell(.Cells(1).RowIndex, .Cells(1).ColumnIndex + 1).Range.Text, vbCr)(0)
Exit For
End If
End With

Next

At the moment, it just grabs the 1st Apple Word it encounters in the 1st table. Is there any possibility to grab the last Apple from the last Table? I tried with .Find and then .Forward = True but it still grabs the 1st encountered one and not the last. Is there any possibility to make it to find the exact word? I tried using String

Many thanks
Best,
John

[macropod]

That's really quite simple. You should spend a little time studying Word's API.

[johngalvin]

Hi
I was thinking of using

.Find(What=SearchWord), but it's currently using With .Find

Trying to make it look for Exact Word, if there are multiple similar words like :Apple, apple, Red Apple, red apple, I want it to make the SearchWord = "Apple" and get only that one for example. I think that would be called to find the Exact Match

This would take more time, so it's not viable, have to try with the .Find function for the Exact match

If InStr(TblCell.Range, SearchWord) Then

EDIT:
Did as below, find the MatchCase as Apple, but it doesen't go to the last result, it stops to the 1st encountered one, any idea how this can be done such as reaching the last found result? I've tried .Forward = True



Dim SearchWord As String
SearchWord = "Apple"



For Each wdTbl In .Tables
With wdTbl.Range
With .Find
.Text = SearchWord
.MatchCase = True
.MatchWholeWord = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = True Then
WkSht.Range("A" & 1).Value = Split(wdTbl.Cell(.Cells(1).RowIndex, .Cells(1).ColumnIndex+1).Range.Text, vbCr)(0)
Exit For
End If
End With

Next