Sub UnderlineTS()
Dim oRng As Range
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(FindText:="TSIATIM")
            oRng.End = oRng.Start + 2
            oRng.Underline = wdUnderlineSingle
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub