按照标题拆分子文档

先对每个word，跑一遍以下代码（或者遍历所有word跑一遍），得到对应word的以子标题为文件名的subdocument。

</pre><pre name="code" class="vb">Option ExplicitSub SplitLevel2()  Dim docCur As Document  Dim docNew As Document  Dim rngTitle As Range  Dim rngChapter As Range  Dim rngTarget As Range  Dim lngStart As Long  Dim lngEnd As Long  Dim lngCnt As Long  Dim strChapter As String  On Error GoTo ErrHandler  Application.ScreenUpdating = False  ' Source document  Set docCur = ActiveDocument  ' Set up to find Header 2  With docCur.Content.Find    .Text = ""    .ClearFormatting    .Style = wdStyleHeading3    .Format = True    ' Find each occurrence    Do While .Execute      ' Start and end of range      lngStart = lngEnd      lngEnd = .Parent.Start      ' Are we at the beginning?      If lngCnt = 0 Then        ' If so, define range with title and TOC        Set rngTitle = docCur.Range(Start:=lngStart, End:=lngEnd)      Else        ' Else, define chapter range        Set rngChapter = docCur.Range(Start:=lngStart, End:=lngEnd)        ' Create new document        Set docNew = Documents.Add        ' Copy and paste title/TOC range to new doc        rngTitle.Copy        docNew.Content.Paste        ' Copy and paste chapter range at end of new doc        rngChapter.Copy        Set rngTarget = docNew.Content        rngTarget.Collapse Direction:=wdCollapseEnd        rngTarget.Paste        ' Update TOC        docNew.TablesOfContents(1).Update        ' Save new doc        docNew.SaveAs strChapter        ' And close it        docNew.Close      End If      ' Set up name for document in next round      strChapter = .Parent.Text      strChapter = Left(strChapter, Len(strChapter) - 1)      ' Increase counter      lngCnt = lngCnt + 1    Loop    ' Handle last chapter separately    Set rngChapter = docCur.Range(Start:=lngEnd, End:=docCur.Content.End)    ' Create new document    Set docNew = Documents.Add    ' Copy and paste title/TOC range to new doc    rngTitle.Copy    docNew.Content.Paste    ' Copy and paste chapter range at end of new doc    rngChapter.Copy    Set rngTarget = docNew.Content    rngTarget.Collapse Direction:=wdCollapseEnd    rngTarget.Paste    ' Update TOC    docNew.TablesOfContents(1).Update    ' Save new doc    docNew.SaveAs strChapter    ' And close it    docNew.Close  End WithExitHandler:  Application.ScreenUpdating = True  Exit SubErrHandler:  MsgBox Err.Description, vbExclamation  Resume ExitHandlerEnd Sub

在excel下，遍历所有word对应的subdocument，并且把word内容以object形式贴在excel上。

局限：贴在excel的word只能显示第一页。

</pre><pre name="code" class="vb">Sub 宏1()'' 宏1 宏''    ActiveSheet.OLEObjects.Add(Filename:= _        "C:\Users\\\文件夹\小标题1-1.docx", Link:=False, DisplayAsIcon:= _        False).Select    ActiveWindow.SmallScroll Down:=18    Range("A48").Select    ActiveSheet.OLEObjects.Add(Filename:= _        "C:\Users\\\文件夹\小标题1-2.docx", Link:=False, DisplayAsIcon:= _        False).Select    ActiveWindow.SmallScroll Down:=24End Sub

Sub OpenCloseArray()    Dim MyFile As String    Dim Arr(100) As String    Dim count As Integer    MyFile = Dir("C:ubdocumnent\新建文件夹\" & "*.docx")    count = count + 1    Arr(count) = MyFile          Do While MyFile <> ""        MyFile = Dir        If MyFile = "" Then            Exit Do        End If        count = count + 1        Arr(count) = MyFile         '将文件的名字存在数组中    Loop          For i = 1 To count        ThisWorkbook.Sheets.Add After:=ActiveSheet        ActiveSheet.OLEObjects.Add(Filename:= _        "C:\\subdocumnent\新建文件夹\" & Arr(i), Link:=False, _        DisplayAsIcon:=False).Select        ActiveSheet.Name = Arr(i)'        Workbooks.Open Filename:="C:\Users\McDelfino\Desktop\2.JPL_SCAT_EXCEL全\" & Arr(i)  '循环打开Excel文件'            Cells(1, 1) = "alex_bn_lee"             '修改打开文件的内容'        ActiveWorkbook.Close savechanges = True     '关闭打开的文件    NextEnd Sub

Sub 链接()Sheets("index").Select '注意'显示所有工作表For i = 1 To Sheets.countCells(i + 1, 2).Value = Sheets(i).NameNext'超链接For i = 1 To Sheets.count   t = Cells(i + 1, 2)   Cells(i + 1, 2).Select   ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=t & "!A1", ScreenTip:="进入", TextToDisplay:=tNextEnd Sub