Sub Macro1()
Dim oRng As Range
Dim oTable As Table
Dim oCell As Range
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(findText:="T. ")
            If oRng.Start = oRng.Paragraphs(1).Range.Start Then
                oRng.End = oRng.Paragraphs(1).Range.End
                oRng.Collapse 0
                Set oTable = ActiveDocument.Tables.Add(oRng, 2, 3)
                With oTable
                    .Columns(1).Width = CentimetersToPoints(1.17)
                    .Columns(2).Width = CentimetersToPoints(1.47)
                    .Columns(3).Width = CentimetersToPoints(13.35)
                    Set oCell = .Cell(1, 1).Range
                    oCell.End = oCell.End - 1
                    oCell.Text = "Date"
                    Set oCell = .Cell(1, 2).Range
                    oCell.End = oCell.End - 1
                    oCell.Text = "Initials"
                    Set oCell = .Cell(1, 3).Range
                    oCell.End = oCell.End - 1
                    oCell.Text = "Remarks"
                End With
            End If
        Loop
    End With
    Set oRng = Nothing
    Set oCell = Nothing
    Set oRng = Nothing
End Sub