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

End Sub