Dim rw1 As Object
Dim G As Integer
For i = 1 To ActiveDocument.Tables(1).Rows.Count
  
   Set rw1 = ActiveDocument.Tables(1).Rows(1).Range
    With rw1
    With .Find
        With .Font
            .Bold = True
        End With
        .Text = ""
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .Execute
         Do While .Execute
            Set rw1 = ActiveDocument.Tables(1).Rows(i).Next
            If Selection.Find.Font.Bold = True Then
              If Selection.Find.Text = "Organization" Or Selection.Find.Text = "Date" Or Selection.Find.Text = "Description" Or Selection.Find.Text = "Aerospace, Space & Defence" Or Selection.Find.Text = "Automotive" Or Selection.Find.Text = "Manufacturing" Or Selection.Find.Text = "Life Sciences" Or Selection.Find.Text = "Information Communication Technologies / Digital" Or "Natural Resources / Energy" Or Selection.Find.Text = "Regional Stakeholders" Or Selection.Find.Text = "Other Policy Priorities" Then
                G = 5
               Else
                    Selection.Collapse Direction:=wdCollapseStart
                    Selection.MoveDown Unit:=wdLine, Count:=1
                    rng.SetRange Start:=Selection.Start, End:=ActiveDocument.Range.End
                    rng.Select
                    With Selection.Find
                        With .Font
                            .Bold = True
                        End With
                        .Text = "Aerospace, Space & Defence" Or "Automotive" Or "Manufacturing" Or "Life Sciences" Or "Information Communication Technologies / Digital" Or "Natural Resources / Energy" Or "Regional Stakeholders" Or "Other Policy Priorities"
                        .MatchCase = True
                        .MatchWholeWord = True
                        If Selection.Find = True Then
                         MsgBox ("A category has been inserted into the middle of the document. Please copy manually or move extra category to the end of the document to continue automation.")
                            Exit Sub
                        ElseIf Selection.Find.Font.Bold = True Then
                         MsgBox ("There is more than one extra category. Please copy manually.")
                            Exit Sub
                        Else
                            rng.Select
                            Selection.Copy
                            ThisDocument.Activate
                            ThisDocument.Tables(1).Columns(1).Select
                            Selection.Collapse Direction:=wdCollapseEnd
                            Selection.PasteAndFormat (wdTableInsertAsRows)
                        End If
                    End With
              End If
            Else
            G = 6
           End If
     Loop
   End With
   End With
Next i