Select certain page on condition in vba - vba

Question

I am writing a script that extract tables from Word file as copies it to a worksheet in Excel. However, the Word files I received do not have the same format and the tables I need are not always on the same page. Hence I cannot use the regular table index.
Each table is on a different page and only on that page there somewhere is a text string (may or may not be in the table itself) like 'material/material list'. What I'd like to do is scan each page of the Word document for a certain textstring and only if that string is present, use the corresponding table on that page. Is this possible and how would I go about this?
A complication of the inconsistent formatting is that on some pages, the data is not even in a table so for those files I'd like an alert if the trigger word is found on a page but no table is there.
Edited:
I have tried to redefine the range considered. My hope is that this is the easiest method; see where the keyword occurs and then use the first table after that. However this does not seem to work.
With ActiveDocument.Content.Find
.Text = "Equipment"
.Forward = True
.Execute
If .Found = True Then Set aRange = ActiveDocument.Range(Start:=0, End:=0)
End With
Edit:
I tried to combine the code from macropod with a vba in Excel that copies the table to the worksheet.
Sub LookForWordDocs()
Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
Dim sFoldPath As String: sFoldPath = FolderName ' Change the path. Ensure that your have "\" at the end of your path
Dim oFSO As New FileSystemObject ' Requires "Microsoft Scripting Runtime" reference
Dim oFile As File
' Loop to go through all files in specified folder
For Each oFile In oFSO.GetFolder(sFoldPath).Files
' Check if file is a word document. (Also added a check to ensure that we don't pick up a temp Word file)
If ((InStr(1, LCase(oFSO.GetExtensionName(oFile.Path)), "doc", vbTextCompare) > 0) Or _
(InStr(1, LCase(oFSO.GetExtensionName(oFile.Path)), "docx", vbTextCompare) > 0)) And _
(InStr(1, oFile.Name, "~$") = 0) And _
((InStr(1, oFile.Name, "k") = 1) Or (InStr(1, oFile.Name, "K") = 1)) Then
' Call the UDF to copy from word document
ImpTable oFile
End If
Next
End Sub
Sub ImpTable(ByVal oFile As File)
Dim oWdApp As New Word.Application
Dim oWdDoc As Word.Document
Dim oWdTable As Word.Table
Dim oWS As Excel.Worksheet
Dim lLastRow$, lLastColumn$
Dim s As String
s = "No correct table found"
With Excel.ThisWorkbook
Set oWS = Excel.Worksheets.Add
On Error Resume Next
oWS.Name = oFile.Name
On Error GoTo 0
Set sht = oWS.Range("A1")
Set oWdDoc = oWdApp.Documents.Open(oFile.Path)
oWdDoc.Activate
'Application.ScreenUpdating = False
Dim StrFnd As String, Rng As Word.Range, i As Long, j As Long
j = 0
StrFnd = "equipment"
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = StrFnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
i = .Information(wdActiveEndAdjustedPageNumber)
Set Rng = Word.ActiveDocument.Goto(What:=wdGoToPage, Name:=i)
Set Rng = Rng.Goto(What:=wdGoToBookmark, Name:="\page")
If Rng.Tables.Count > 0 Then
With Rng.Tables(1)
Set oWdTable = Rng.Tables(1)
oWdTable.Range.Copy
sht.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
j = 1
End With
End If
.Start = Rng.End
.Find.Execute
Loop
End With
If j = 0 Then sht.Value = s
'Application.ScreenUpdating = True
oWdDoc.Close savechanges:=False
oWdApp.Quit
End With
Set oWS = Nothing
Set sht = Nothing
Set oWdDoc = Nothing
Set oWdTable = Nothing
Set Rng = Nothing
End Sub
For the first file, the code works fine. However on the second run I get a run-time error "The remote Server Machine does not Exist or is unavailable" on line
"Word.ActiveDocument.Range". I added a couple of qualifications for elements but this still did not solve the problem. Am I missing another line?
BTW When I place "Word" before ActiveDocument.Range the code does not work any more.

Answer 1

Since you've changed the text from 'material/material list' to 'Equipment', it's a bit hard to know quite what you want. Try something along the lines of:
Sub Demo()
Application.ScreenUpdating = False
Dim StrFnd As String, Rng As Range, i As Long
StrFnd = InputBox("What is the Text to Find")
If Trim(StrFnd) = "" Then Exit Sub
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = StrFnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
i = .Information(wdActiveEndAdjustedPageNumber)
Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
If Rng.Tables.Count > 0 Then
MsgBox Chr(34) & StrFnd & Chr(34) & " and table found on page " & i & "."
With Rng.Tables(1)
'process this table
End With
Else
MsgBox Chr(34) & StrFnd & Chr(34) & " found on page " & i & " but no table."
End If
.Start = Rng.End
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
Note: the above code will test all pages on which the Find text is found.