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.Range
          With Rng
            .End = .End - 2
            Str1 = Trim(.Text)
          End With
        End If
        With .Find
          .Text = "R"
          .Execute
        End With
        If .Find.Found Then
          Set Rng = .Duplicate.Paragraphs.Last.Range
          With Rng
            .End = .End - 1
            .Start = .Start + 4
            Str2 = Trim(.Text)
          End With
        End If
    End With
    .SaveAs2 FileName:=.Path & "\" & Str1 & " " & Str2, FileFormat:=wdFormatDocumentDefault
End With