extract table that consist of a particular title from multiple word documents into excel

[Natasha77]

Need some help with this code please help. I need it to extract tables containing certain text from multiple word docs into an excel worksheet

Sub ExportRules()
Dim lngIndex As Long, strExcelFile As String, strSheet As String, bFound As Boolean
Dim xlApp As Object, xlBook As Object, xlSheet As Object, bStart As Boolean
'Mod by GKM
strExcelFile = FileDialogFile
Select Case fcnGetFileExtension(strExcelFile)
Case "xls", "xlsx", "xlsm"
Case Else
MsgBox "You either did not select a file or the file you selected is not a Excel data file", vbExclamation + vbOKOnly, "Invalid File"
End Select
'End mod
Application.ScreenUpdating = True
strSheet = "Sheet1": bStart = False: bFound = False

'Test whether Excel is already running.
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
GoTo ErrExit
End If
bStart = True
End If
On Error GoTo 0
'Check if the workbook is open.
With xlApp
For Each xlBook In .Workbooks
If xlBook.FullName = strExcelFile Then ' It's open
Set xlBook = xlBook
bFound = True
Exit For
End If
Next
' If not open by the current user.
If bFound = False Then
' Check if another user has it open.
If IsFileLocked(strExcelFile) = True Then
' Report and exit if true
MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
If bStart = True Then .Quit
GoTo ErrExit
End If
' The file is available, so open it.
Set xlBook = .Workbooks.Open(FileName:=strExcelFile)
If xlBook Is Nothing Then
MsgBox "Cannot open:" & vbCr & strExcelFile, vbExclamation
If bStart = True Then .Quit
GoTo ErrExit
End If
End If
Set xlSheet = xlBook.Worksheets(strSheet)
On Error GoTo 0
' Find the last-used row in column A.
' Add 1 to get the next row for data-entry.
lngIndex = xlSheet.Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
' Output the rules.
With ActiveDocument
.ConvertNumbersToText
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "Rule[ ]@[0-9.-]@:*^13"
.Execute
End With
'Ask the user whether to change the found text
Do While .Find.Found
lngIndex = lngIndex + 1
xlSheet.Cells(lngIndex, 1).Value = "Rule"
xlSheet.Cells(lngIndex, 2).Value = Trim(Split(Split(.Text, ":")(0), "Rule")(1))
xlSheet.Cells(lngIndex, 3).Value = Trim(Right(.Text, Len(.Text) - InStr(.Text, ":")))
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
'Mod by GKM
xlBook.Save
If bStart Then
xlBook.Close
xlApp.Quit
End If
'End mods
End With

ErrExit:
' Release Excel object memory
Set xlSheet = Nothing: Set xlBook = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub
Function IsFileLocked(strFileName As String) As Boolean
On Error Resume Next
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
IsFileLocked = Err.Number
Err.Clear
End Function
'Note that the macro assumes an Excel workbook named 'Rules.xls' exists in your Documents folder and that the output goes to Sheet1. You can change the details in the code.
Function FileDialogFile(Optional strCaption As String = "") As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = strCaption
If .Show Then
FileDialogFile = .SelectedItems(1)
Else
FileDialogFile = ""
End If
End With
End Function
Function fcnGetFileExtension(ByRef strFileName As String) As String
'Gets the extention assigned to a file including the delimiter "."
On Error GoTo Err_NoExtension
fcnGetFileExtension = VBA.Right(strFileName, Len(strFileName) - (InStrRev(strFileName, ".", -1, vbTextCompare)))
If fcnGetFileExtension = strFileName Then
'There is no extension
fcnGetFileExtension = ""
End If
lbl_Exit:
Exit Function
Err_NoExtension:
Resume lbl_Exit
End Function

 

[Macropod]

Please correct your post by using code tags and formatted code. Then explain what the issue is...