Sub CopyCurrentSectionToNewDoc()
  Dim Rng as Range, NewDoc as Document, currentSection as Long

  currentSection = Selection.Information(wdActiveEndSectionNumber)
  Set Rng = ActiveDocument.Sections(currentSection).Range
  Rng.MoveEnd wdCharacter, -1
  
  Set NewDoc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=True)
  
  ' Transfer contents into the output document, preserving the formatting
  NewDoc.Range.FormattedText = Rng.FormattedText
 
End Sub