Const myKeyTerms            As String = _
    "Aerospace, Space & Defence"
Dim myTable                 As Table
Dim myRow                   As Row
Dim myRange                 As Range
Dim myRange2                 As Range
Dim myTable2                 As Table
Dim myRow2                   As Row
Documents.Open ("")
    For Each myTable In ActiveDocument.Tables
        For Each myRow In myTable.Rows
            ' If successful myrange is moved to the found text
            Set myRange = myRow.Range
            ' Search parameters are persistent so you only need to change them if the search parameters change
            With myRange.Find
                .Font.Bold = True
                .Text = ""
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .Wrap = wdFindStop
                .Forward = True
                ' Stop when the range is searched
                ' .Execute returns true if the search is found
                Do While .Execute
                    ' myRange is now the found term
                    myRange.Select
                    If InStr(myKeyTerms, myRange.Text) > 0 Then
                        'Actions to do if the row contained a key term in bold
                       myRange.Copy
                       ThisDocument.Activate
                       For Each myTable2 In ActiveDocument.Tables
                        For Each myRow2 In myTable2.Rows
                            ' If successful myrange is moved to the found text
                        Set myRange2 = myRow2.Range
                            ' Search parameters are persistent so you only need to change 'them if the search parameters change
                             With myRange2.Find
                            .Font.Bold = True
                            .Text = ""
                            .Format = True
                            .MatchCase = False
                            .MatchWholeWord = False
                            .MatchWildcards = False
                            .Wrap = wdFindStop
                            .Forward = True
                            ' Stop when the range is searched
                            ' .Execute returns true if the search is found
                             Do While .Execute
                                ' myRange is now the found term
                                myRange2.Select
                                If InStr(myKeyTerms, myRange2.Text) > 0 Then
                                    Selection.PasteAndFormat (wdTableInsertAsRows)
                                    Exit Sub
                                End If
                          '  reset myRange to encompass the rest of the row
                                myRange2.Start = myRange2.End + 1
                                myRange2.End = myRow2.Range.End
                                
                                myRange2.Select
                                Loop
                                End With
                                Next myRow2
                                Next myTable2
                    End If
                    ' now we need to reset myRange to encompass the rest of the row
                    myRange.Start = myRange.End + 1
                    myRange.End = myRow.Range.End
                                       myRange.Select
                Loop
            End With
        Next myRow
    Next myTable
End Sub