vba - Copy headings and Contents to new document - Stack Overflow Sub SplitDocumentByHeading() Application.ScreenUpdating = False Dim DocSrc As Document, DocTgt As Document, Rng As Range, i As Long Dim StrTmplt As String, StrNm As String, StrEx As String, lFmt As Long Set DocSrc = ActiveDocument With DocSrc StrTmplt = .AttachedTemplate.FullName StrNm = Split(.FullName, ".doc")(0) StrEx = Split(.FullName, ".doc")(1) lFmt = .SaveFormat With .Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "" .Style = wdStyleHeading1 .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute End With Do While .Find.Found i = i + 1 Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel") Set DocTgt = Documents.Add(Template:=StrTmplt, Visible:=False) With DocTgt .Range.FormattedText = Rng.FormattedText .SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False 'this sets the format .Close End With .Collapse wdCollapseEnd .Find.Execute Loop End With End With Set DocTgt = Nothing: Set Rng = Nothing: Set DocSrc = Nothing Application.ScreenUpdating = True End Sub