|
Option Explicit
Sub TEST()
Dim ar, br, i&, r&, wdApp As Object, strFileName$, strPath$
strPath = ThisWorkbook.Path & "\"
strFileName = strPath & "yx2.docx"
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)
ar = Split(.Content.Text, vbCr)
ReDim br(UBound(ar) + 1, 1)
br(0, 0) = "院校名称": br(0, 1) = "介绍"
For i = 0 To UBound(ar)
If InStr(ar(i), "■") Then
r = r + 1
br(r, 0) = ar(i)
Else
If Len(ar(i)) Then
If Len(br(r, 1)) = False Then
br(r, 1) = ar(i)
Else
br(r, 1) = br(r, 1) & vbCrLf & ar(i)
End If
End If
End If
Next i
.Close False
End With
Cells.Delete
With [A1].Resize(r + 1, 2)
.Value = br
.Borders.LineStyle = xlContinuous
.Rows(1).HorizontalAlignment = xlCenter
.EntireRow.AutoFit
.EntireColumn.AutoFit
.EntireRow.AutoFit
End With
If Err <> 0 Then wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
Beep
End Sub
|
|