Sub SaveEachSectionAsADoc()
  Dim objDocAdded As Document
  Dim objDoc As Document
  Dim nSectionNum As Integer
  Dim strFolder As String

  Dim dlgFile As FileDialog
 
  ' Initialization
  Set objDoc = ActiveDocument
 
  Set dlgFile = Application.FileDialog(msoFileDialogFolderPicker)
 
  ' Pick a location to keep new files.
  With dlgFile
    If .Show = -1 Then
      strFolder = .SelectedItems(1) & "\"
    Else
      MsgBox "Select a folder first!"
      Exit Sub
    End If
  End With
 
  ' Step through each section in current document, copy and paste each to a new one.
  For nSectionNum = 1 To ActiveDocument.Sections.Count
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:=nSectionNum
    ActiveDocument.Sections(nSectionNum).Range.Copy
 
    Set objDocAdded = Documents.Add
    Selection.Paste
 
    ' Save and close new documents.
    objDocAdded.SaveAs FileName:=strFolder & "Section " & nSectionNum & ".docx"
    objDocAdded.Close
  Next nSectionNum
End Sub

Sub BreakOnSection()
    Dim i As Long
    Dim DocNum As Long
    Dim docOld As Document
    Dim docNew As Document

    Set docOld = ActiveDocument

    'A mail merge document ends with a section break next page.
    'Subtracting one from the section count stop error message.
    For i = 1 To docOld.Sections.Count
        'Select and copy the section text to the clipboard.
        docOld.Sections(i).Range.Copy

        'Create a new document to paste text from clipboard.
        Set docNew = Documents.Add
        Selection.Paste

        ' Removes the break that is copied at the end of the section, if any.
        Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1
        DocNum = DocNum + 1
        docNew.SaveAs FileName:="Section_" & DocNum & ".docx", _
            FileFormat:=wdFormatXMLDocument
        docNew.Close
        'Move the selection to the next section in the document.
        Application.Browser.Next
    Next i

    docOld.Close SaveChanges:=wdDoNotSaveChanges
End Sub

Option Explicit
'Add Microsoft Scripting Runtime to Resourses before using this procedure
Public pPath As String
Public pFileName As String
Public pSrcFileName As String
Sub CallUF()
Dim myFrm As UserForm1
If Not ActiveDocument.Saved Then
  If MsgBox("You must save this document before running this procedure." _
          & " Do you want to save it now?", vbQuestion + vbYesNo, _
            "File Not Saved") = vbYes Then
    ActiveDocument.Save
  Else
    Exit Sub
  End If
End If
pSrcFileName = ActiveDocument.FullName
Set myFrm = New UserForm1
myFrm.Show
Unload myFrm
Set myFrm = Nothing
End Sub
Function DirPath(ByRef strVer As String) As String
'Add Microsoft Scripting Runtime to Resourses before running this code
On Error GoTo Err_Handler
Select Case strVer
  Case "11.0", "12.0", "14.0"
    Dim fso As New FileSystemObject
    Dim fd As FileDialog
    Dim AbsolutePath As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
      .Title = "Pick the destination directory for the new files."
      .AllowMultiSelect = False
      .InitialView = msoFileDialogViewList
      If .Show = -1 Then
        AbsolutePath = fso.GetAbsolutePathName(.SelectedItems.Item(1))
        If Right(AbsolutePath, 1) <> "\" Then AbsolutePath = AbsolutePath + "\"
        DirPath = AbsolutePath
      Else
        DirPath = "****CANCELED BY USER****"
      End If
    End With
  Case Else
Err_ReEntry:
    AbsolutePath = InputBox("Enter the directory path where you want to " _
              & "save the individual files.", "File Path", "C:\")
    If Right(AbsolutePath, 1) <> "\" Then AbsolutePath = AbsolutePath + "\"
    DirPath = AbsolutePath
End Select
On Error GoTo 0
Exit Function
Err_Handler:
Resume Err_ReEntry
End Function
Function SaveAsType(ByRef oDoc_Passed) As Long
SaveAsType = oDoc_Passed.SaveFormat
End Function
Function GetExtension(ByRef strFileName As String) As String
Dim arrStrings() As String
arrStrings() = Split(strFileName, ".")
If UBound(arrStrings) > 0 Then
  GetExtension = arrStrings(UBound(arrStrings))
End If
End Function

Sub SaveEachSectionAsADoc()
  Dim objDocAdded As Document, objDoc As Document
  Dim nSectionNum As Integer, strFolder As String
  Dim dlgFile As FileDialog
 
  ' Initialization
  Set objDoc = ActiveDocument
 
  Set dlgFile = Application.FileDialog(msoFileDialogFolderPicker)
 
  ' Pick a location to keep new files.
  With dlgFile
    If .Show = -1 Then
      strFolder = .SelectedItems(1) & "\"
    Else
      MsgBox "Select a folder first!"
      Exit Sub
    End If
  End With
 
  ' Step through each section in current document, copy and paste each to a new one.
  For nSectionNum = 1 To objDoc.Sections.Count
    Set objDocAdded = Documents.Add(Template:=objDoc.FullName)
    objDocAdded.Range.FormattedText = objDoc.Sections(nSectionNum).Range.FormattedText
    ' Save and close new documents.
    objDocAdded.SaveAs FileName:=strFolder & "Section " & nSectionNum & ".docx"
    objDocAdded.Close
  Next nSectionNum
End Sub