'将长文档中的同一级别的内容分别拆分为一个新文件，并同时以新文件内容第一行为文件名保存在当前文件夹中。

Sub 按大纲级别拆分文件()

Dim rngrange As Range

Dim doc As Document

Dim i As Integer

Dim j As Integer

Dim mys As String

Dim levi As Integer

Dim levj As Integer

Dim contt As String

Dim spendtimestr As String

Application.ScreenUpdating = False

mypath = ActiveDocument.Path

starttime = Time

For i = 1 To ActiveDocument.Paragraphs.Count

If ActiveDocument.Range.Paragraphs(i).OutlineLevel = wdOutlineLevel2 Then

levi = ActiveDocument.Range.Paragraphs(i).OutlineLevel

Set myRange = ActiveDocument.Paragraphs(i).Range

myRange.SetRange myRange.Start, myRange.End - 1

iFilename = Trim(myRange.Text)

j = i 'J等于i,即找到目标的段落，关键点之一

Do

'从即找到目标的段落i开始，依次往后找，一直到找到级别小于或等于目标段落的段落或找到文章的最后，关键点之二

j = j + 1

levj = ActiveDocument.Range.Paragraphs(j).OutlineLevel

Loop Until (levj < levi Or levj = levi Or j = ActiveDocument.Paragraphs.Count)

'级别小于或等于目标段落的段落或找到文章的最后，关键点之三

'如果是件末，则将最后一段内容同时拷贝

If j = ActiveDocument.Paragraphs.Count Then

Set rngrange = ActiveDocument.Range(ActiveDocument.Paragraphs(i).Range.Start, ActiveDocument.Paragraphs(j).Range.End)

rngrange.Select

Selection.Copy

Else

Set rngrange = ActiveDocument.Range(ActiveDocument.Paragraphs(i).Range.Start, ActiveDocument.Paragraphs(j - 1).Range.End)

rngrange.Select

Selection.Copy

End If

Documents.Add

With ActiveDocument.Content

.Paste

End With

Call 页面设置

ActiveDocument.SaveAs FileName:=mypath & "\" & iFilename, FileFormat:=wdFormatPDF ActiveDocument.Close savechanges:=wdDoNotSaveChanges

Else

End If

Next i

endtime = Time

spendtime = Round((endtime - starttime) * 24 * 60 * 60, 3)

spendtimestr = "共费时：" & spendtime & "秒"

MsgBox (spendtimestr)

Application.ScreenUpdating = True

End Sub

Sub 页面设置()

With ActiveDocument.PageSetup

.LineNumbering.Active = False

.Orientation = wdOrientPortrait

.TopMargin = CentimetersToPoints(2)

.BottomMargin = CentimetersToPoints(1.4)

.LeftMargin = CentimetersToPoints(1.8)

.RightMargin = CentimetersToPoints(1.8)

.Gutter = CentimetersToPoints(0)

.HeaderDistance = CentimetersToPoints(1.5)

.FooterDistance = CentimetersToPoints(1.2)

.PageWidth = CentimetersToPoints(14.8)

.PageHeight = CentimetersToPoints(21)

.FirstPageTray = wdPrinterDefaultBin

.OtherPagesTray = wdPrinterDefaultBin

.SectionStart = wdSectionNewPage

.OddAndEvenPagesHeaderFooter = False

.DifferentFirstPageHeaderFooter = False

.VerticalAlignment = wdAlignVerticalTop