Option Explicit
Sub SplitDocsToFolders()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document
Dim Rng As Range, BkMk As Bookmark
Dim StrPth As String, StrNm As String, StrFld As String
'browse to a folder
StrPth = GetFolder & "\"
If StrPth = "\" Then Exit Sub
StrNm = Dir(StrPth & "\*.doc", vbNormal)
'process all files in the source folder
While StrNm <> ""
  'open the source document
  Set DocSrc = Documents.Open(FileName:=StrPth & StrNm, _
      AddToRecentFiles:=False, Visible:=False)
  With DocSrc
    If .Bookmarks.Count > 0 Then
      'find the ranges from one bookmark to the next
      For Each BkMk In .Bookmarks
        If BkMk.StoryType = wdMainTextStory Then
          'get the bookmark's name
          StrFld = BkMk.Name & "\"
          'find the range spanned till the next bookmark
          Set Rng = BkMk.Range
          With Rng
            Do While .Bookmarks.Count = 1
              .MoveEnd wdParagraph, 1
              If .End = DocSrc.Range.End Then Exit Do
            Loop
            Do While .Bookmarks.Count > 1
              .MoveEnd wdSentence, -1
            Loop
            Do While .Bookmarks.Count < 2
              .MoveEnd wdWord, 1
              If .End = DocSrc.Range.End Then Exit Do
            Loop
            Do While .Bookmarks.Count > 1
              .MoveEnd wdCharacter, -1
            Loop
            .Start = BkMk.Range.Start
            If .End > .Start Then
              'copy the spanned range
              .Copy
              'create the output folder, if necessary, using the bookmark's name
              If Dir(StrPth & StrFld, vbDirectory) = "" Then MkDir (StrPth & StrFld)
              'create the output document
              Set DocTgt = Documents.Add(Visible:=False)
              With DocTgt
                'add the content to the new document
                .Range.Paste
                'save the document to its folder, then close it
                .SaveAs2 FileName:=StrPth & StrFld & StrNm, _
                    Fileformat:=DocSrc.Type, AddToRecentFiles:=False
                .Close False
              End With
            End If
          End With
        End If
      Next
    End If
    .Close False
  End With
  'process the next document
  StrNm = Dir()
Wend
'cleanup
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function