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)
    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"
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found
        .MoveEndUntil Chr(13) & Chr(13), wdForward
        DocTgt.Range.Characters.Last.FormattedText = .FormattedText
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    With DocTgt
      With .Range
        .Characters.First.Delete
        .Characters.First.Delete
      End With
      .SaveAs2 FileName:=DocSrc.Path & "\" & StrTmp & ".docx", _
        Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
      .Close
    End With
  Next
  With .Range
    .Characters.First.Delete
    .Characters.First.Delete
  End With
End With
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub