'將長(zhǎng)文檔中的同一級(jí)別的內(nèi)容分別拆分為一個(gè)新文件,，并同時(shí)以新文件內(nèi)容第一行為文件名保存在當(dāng)前文件夾中。

Sub 按大綱級(jí)別拆分文件()

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,即找到目標(biāo)的段落,，關(guān)鍵點(diǎn)之一

Do

'從即找到目標(biāo)的段落i開(kāi)始,，依次往后找，一直到找到級(jí)別小于或等于目標(biāo)段落的段落或找到文章的最后,，關(guān)鍵點(diǎn)之二

j = j + 1

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

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

'級(jí)別小于或等于目標(biāo)段落的段落或找到文章的最后,，關(guān)鍵點(diǎn)之三

'如果是件末，則將最后一段內(nèi)容同時(shí)拷貝

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)