Const myKeyTerms            As String = _
    "OrganizationDate+Description+Aerospace, Space & Defence+Automotive+Manufacturing+Life Sciences+Information Communication Technologies / Digital+Natural Resources / Energy+Regional Stakeholders+Other Policy Priorities+NIL+Nil+nil"
Dim i                       As Integer
Dim myTable                 As Table
Dim myFirstRange            As Range
Dim mySecondRange           As Range
Dim myRemoveRange           As Range
Dim SecondRangeFlag         As Boolean
i = ThisDocument.Tables.Count
Documents.Open ("")
    For Each myTable In ActiveDocument.Tables
        Set myFirstRange = Nothing
        SecondRangeFlag = False
        Do
            If myFirstRange Is Nothing Then
                Set myFirstRange = fnFindBold(mySearchRange:=myTable.Range.Rows(1).Range)
            Else
                Set myFirstRange = fnFindBold(mySearchRange:=myFirstRange.Next(Unit:=wdRow))
            End If
            ' two possible cases for myFirstrange
            ' 1. a found range
            ' 2. nothing - which means we have searched the whole table.
            If Not myFirstRange Is Nothing Then
                If InStr(myKeyTerms, myFirstRange.Text) = 0 Then
                    ' Found bold text that is not a defined category (key term)
                    Set mySecondRange = myFirstRange.Duplicate
                    Do
                        Set mySecondRange = fnFindBold(mySecondRange.Next(Unit:=wdRow))
                        If mySecondRange Is Nothing Then
                            SecondRangeFlag = True
                        Else
                            If InStr(myKeyTerms, mySecondRange.Text) > 0 Then
                                SecondRangeFlag = True
                            End If
                        End If
                    Loop Until SecondRangeFlag
                    'We have now found text that is a defined category key term
                    Set myRemoveRange = myFirstRange.Duplicate
                    If mySecondRange Is Nothing Then
                        myRemoveRange.End = myTable.Range.End
                        Set myFirstRange = Nothing
                    Else
                        myRemoveRange.End = mySecondRange.Previous(Unit:=wdRow).End
                        Set myFirstRange = mySecondRange
                    End If
                    myRemoveRange.Select
                    myRemoveRange.Copy
                    ThisDocument.Tables(i).Select
                    Selection.Collapse Direction:=wdCollapseEnd
                    Selection.PasteAndFormat (wdTableInsertAsRows)
                    i = i + 1
                    Documents("").Activate
                    ActiveDocument.Tables(1).Select
                    Selection.Collapse Direction:=wdCollapseEnd
                    Selection.PasteAndFormat (wdTableInsertAsRows)
                    myRemoveRange.Select
                    myRemoveRange.Cut
                End If
            End If
        Loop Until myFirstRange Is Nothing
    Next myTable
End Sub