按照标题拆分子文档

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

Option Explicit

Sub 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 With

ExitHandler:
  Application.ScreenUpdating = True
  Exit Sub

ErrHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

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

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

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:=24
End 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     '关闭打开的文件
    Next
End Sub

Sub 链接()


Sheets("index").Select '注意


'显示所有工作表


For i = 1 To Sheets.count


Cells(i + 1, 2).Value = Sheets(i).Name


Next


'超链接


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:=t


Next


End Sub