Sub Macro1()
Dim oTable As Table
Dim oCell As Cell
Dim oRng As Range, oHeader As Range
Dim oColl As Collection
Dim i As Long, j As Long
    j = 0
    Set oColl = New Collection
    For Each oTable In ActiveDocument.Tables
        For Each oCell In oTable.Range.Cells
            If InStr(1, oCell.Range.Text, "HELLO") > 0 Then
                If oCell.Range.Font.ColorIndex = wdBlue Then
                    j = j + 1
                    Set oRng = oCell.Previous.Range
                    oRng.End = oRng.End - 1
                    oRng.Bookmarks.Add "BM" & j
                    Set oHeader = oCell.Range.Sections(1).Headers(wdHeaderFooterPrimary).Range
                    oHeader.End = oHeader.End - 1

                    Select Case True
                        Case InStr(1, oRng.Text, "APPLE") > 0
                            oColl.Add "I LIKE APPLES|" _
                                      & oRng.Text & "|" _
                                      & oHeader.Text & "|" _
                                      & oRng.Information(wdActiveEndPageNumber)
                        Case InStr(1, oRng.Text, "CAR RESALES") > 0
                            oColl.Add "I DON'T LIKE BANANA|" _
                                      & oRng.Text & "|" _
                                      & oHeader.Text & "|" & _
                                      oRng.Information(wdActiveEndPageNumber)
                    End Select
                End If
            End If
        Next oCell
    Next oTable
    Set oRng = ActiveDocument.Range
    oRng.Collapse 0
    oRng.InsertParagraphBefore
    Set oTable = ActiveDocument.Tables.Add(oRng, oColl.Count + 1, 4)
    With oTable
        .Columns(1).Width = CentimetersToPoints(4)
        .Columns(2).Width = CentimetersToPoints(5)
        .Columns(3).Width = CentimetersToPoints(4.5)
        .Columns(4).Width = CentimetersToPoints(1.5)
        .Rows(1).Range.Font.Bold = True
        .Cell(1, 1).Range.Text = "Certification"
        .Cell(1, 2).Range.Text = "Title"
        .Cell(1, 3).Range.Text = "Section"
        .Cell(1, 4).Range.Text = "Page"
        .Rows(1).HeadingFormat = True
        For i = 1 To oColl.Count
            .Rows(i + 1).Cells(1).Range.Text = Split(oColl(i), "|")(0)
            .Rows(i + 1).Cells(2).Range.Text = Split(oColl(i), "|")(1)
            .Rows(i + 1).Cells(3).Range.Text = Split(oColl(i), "|")(2)
            .Rows(i + 1).Cells(4).Range.Text = Split(oColl(i), "|")(3)
            ActiveDocument.Hyperlinks.Add _
                    Anchor:=.Rows(i + 1).Cells(4).Range, _
                    Address:="", _
                    SubAddress:="BM" & Split(oColl(i), "|")(3), _
                    ScreenTip:="", _
                    TextToDisplay:=Split(oColl(i), "|")(3)
        Next i
    End With
lbl_Exit:
    Set oTable = Nothing
    Set oCell = Nothing
    Set oRng = Nothing
    Set oHeader = Nothing
    Set oColl = Nothing
    Exit Sub
End Sub