Sub TextToComments()
Dim oDoc As Document
Dim oRng As Range
Dim MyString As String
Dim myUsername As String
Dim myUserinitials As String
Dim oComment As Comment

    myUsername = Application.UserName
    myUserinitials = Application.UserInitials
    Application.UserName = "JSmith"
    Application.UserInitials = "JS"
    Application.ScreenUpdating = False
    Set oDoc = ActiveDocument
    oDoc.TrackRevisions = False
    Set oRng = oDoc.Range
    oRng.Paragraphs.LineSpacingRule = wdLineSpaceSingle
    With oRng.ParagraphFormat
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 6
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
    End With
    With oRng.Find
        Do While .Execute(FindText:="(\[*\])", MatchWildcards:=True)
            MyString = oRng.Text
            MyString = Mid(MyString, 2, Len(MyString) - 2)
            If Not Left(MyString, 3) = "TS:" Then
                MyString = Mid(MyString, InStr(1, MyString, ":") + 2)
                oRng.Text = MyString
                Set oComment = oDoc.Comments.Add(oRng, MyString)
                If Val(Application.Version) > 14 Then
                    oComment.Author = Application.UserName
                End If
                oRng.Font.Bold = False
            End If
            oRng.Collapse 0
        Loop
    End With
    oRng.Collapse 1
    oRng.Select
    Application.ScreenUpdating = True
    Application.UserName = myUsername
    Application.UserInitials = myUserinitials
lbl_Exit:
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oComment = Nothing
    Exit Sub
End Sub