</pre><pre name="code" class="vb">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
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
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 L