Sub Test()
Dim Rng As Range, Str1 As String, Str2 As String
With ThisDocument
  With .Content
    With .Find
      .ClearFormatting
      .MatchWildcards = True
      .Text = "The Principal"
      .Execute
    End With
    If .Find.Found Then
      Set Rng = .Duplicate.Paragraphs.Last.Next.Range
      With Rng
        While Not .Characters.Last Like "[a-z]"
          .End = .End - 1
        Wend
        Str1 = Trim(.Text)
      End With
    End If
  End With
  With .Content
    With .Find
      .ClearFormatting
      .MatchWildcards = True
      .Text = "RE: [!13]@^13"
      .Execute
    End With
    If .Find.Found Then
      Set Rng = .Duplicate
      With Rng
        While Not .Characters.Last Like "[a-z]"
          .End = .End - 1
        Wend
        .Start = .Start + 4
        Str2 = Trim(.Text)
      End With
    End If
  End With
  MsgBox .Path & "\" & Str1 & " " & Str2
  '.SaveAs2 FileName:=ThisDocument.Path & "\" & Str1 & " " & Str2, FileFormat:=wdFormatDocumentDefault
End With
End Sub