|
|
Sub TEST()
Dim wdApp As Object, wdDoc As Object, ar, i&, r&, strParTxt$
Dim Items As FileDialogSelectedItems, vItem, strPath$
strPath = ThisWorkbook.Path & "\"
With Application.FileDialog(1)
With .Filters
.Clear
.Add "Word文档(doc?)", "*.doc?"
End With
.AllowMultiSelect = True
.InitialFileName = strPath
If .Show Then Set Items = .SelectedItems Else Exit Sub
End With
Application.ScreenUpdating = False
ReDim ar(1 To 10 ^ 3, 1 To 1)
Set wdApp = CreateObject("Word.Application")
For Each vItem In Items
Set wdDoc = wdApp.documents.Open(vItem)
With wdDoc
For i = 1 To .Paragraphs.Count
strParTxt = .Paragraphs(i).Range.Text
If Len(strParTxt) <> 1 And Right(strParTxt, 1) = Chr(13) Then
r = r + 1
ar(r, 1) = Left(strParTxt, Len(strParTxt) - 1)
End If
Next
End With
MsgBox wdDoc.Name
wdDoc.Close False
Next
Cells.Clear
[A1].Resize(r, 1) = ar
With [A1].Resize(r)
.Value = ar
.WrapText = True
.ColumnWidth = 100
.EntireRow.AutoFit
End With
wdApp.Quit
Set wdApp = Nothing: Set wdDoc = Nothing: Set Items = Nothing
Application.ScreenUpdating = True
Beep
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-1-19 21:57
楼主
