|
Option Explicit
Sub test()
Dim ar(), i&, j&, r&, wdApp As Object, strFileName$, strPath$
strPath = ThisWorkbook.Path & "\"
strFileName = strPath & "目录.doc"
If Dir(strFileName) = "" Then MsgBox "指定的文件不存在,请检查!", vbExclamation: Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
With wdApp.documents.Open(strFileName)
With .Content.Find
.ClearFormatting
.Text = "加入收藏夹^p"
.Forward = True
Do While .Execute
r = r + 1
ReDim Preserve ar(1 To r)
Set ar(r) = wdApp.ActiveDocument.Range(.Parent.Start, .Parent.End)
Loop
End With
For i = UBound(ar) To 1 Step -1
If i = 1 Then
Set ar(i) = .Range(0, ar(i).Start)
Else
Set ar(i) = .Range(ar(i - 1).End, ar(i).Start)
End If
Next i
With ActiveSheet
.Cells.Delete
.Rows(3).RowHeight = 364.5
For i = 1 To UBound(ar)
.Columns(i + 1).ColumnWidth = 40
ar(i).Copy
.Cells(2, i + 1).Select
.Paste
Next i
End With
.Close False
End With
If Err <> 0 Then wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
Beep
End Sub
|
评分
-
4
查看全部评分
-
|