Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrTmp As String, StrNames As String
Dim DocSrc As Document, DocTgt As Document
StrNames = "|"
Set DocSrc = ActiveDocument
With DocSrc
  With .Range
    .InsertBefore Chr(13) & Chr(13)
    .InsertAfter Chr(13)
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "^13^13[!^13]@^13"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found
      StrTmp = Trim(Split(.Text, "/")(0))
      StrTmp = Split(StrTmp, " ")(UBound(Split(StrTmp, " ")))
      If InStr(StrNames, "|" & StrTmp & "|") = 0 Then StrNames = StrNames & StrTmp & "|"
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  For i = 1 To UBound(Split(StrNames, "|")) - 1
    StrTmp = Split(StrNames, "|")(i)
    Set DocTgt = Documents.Add
    With .Range
      With .Find
        .Text = "^13^13[!^13]@" & StrTmp & "*^13^13"
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found
        .Start = .Start + 1
        .End = .End - 1
        DocTgt.Range.Characters.Last.FormattedText = .FormattedText
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    With DocTgt
      .Range.Characters.First.Delete
      .Range.Characters.Last.Delete
      .SaveAs2 FileName:=DocSrc.Path & "\" & StrTmp & ".docx", _
        Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
      .Close
    End With
  Next
  With .Range
    .Characters.First.Delete
    .Characters.First.Delete
    .Characters.Last.Delete
  End With
End With
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub