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