Probably something like
Code:
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