Sub GetWordText改进() Dim Wb As Workbook Dim Sht As Worksheet Dim Rng As Range Dim wdApp As Object Dim wdDoc As Object Dim FilePaths Dim FilePath Dim Arr(1 To 10000, 1 To 6) Dim n As Long Dim Index As Long Dim Regex As Object Dim Mh As Object Pattern = ".*?[::](S*)s*?.*?[::](S*)s*?" & _ ".*?[::](S*)s*?.*?[::](S*)s*?" & _ ".*?[::](S*)s*?.*?[::](S*)" Set Regex = CreateObject("VBScript.RegExp") With Regex .Global = True .Pattern = Pattern End With Set Wb = Application.ThisWorkbook Set Sht = Wb.Worksheets("汇总") With Sht .UsedRange.Offset(1).ClearContents End With FilePaths = FsoGetFiles(Wb.Path & "", "*.doc*") If FilePaths(1) = "None" Then Exit Sub Index = 0 Set wdApp = CreateObject("Word.Application") For n = LBound(FilePaths) To UBound(FilePaths) 'On Error Resume Next Set wdDoc = wdApp.documents.Open(FilePaths(n)) If wdDoc Is Nothing Then GoTo NextDocument Else If wdDoc.Tables.Count > 0 Then Debug.Print "含表格:"; FilePaths(n) Index = Index + 1 For j = 1 To 6 Text = wdDoc.Tables(1).cell(1, j).Range.Text Text = Replace(Text, Chr(10), "") Text = Replace(Text, Chr(7), "") Text = Replace(Text, Chr(13), "") Arr(Index, j) = "'" & Text Debug.Print Index; " "; Arr(Index, j) Next j Else Debug.Print "纯文本:"; FilePaths(n) If Regex.test(wdDoc.Content.Text) Then Set Mh = Regex.Execute(wdDoc.Content.Text) Index = Index + 1 For j = 0 To Mh.Item(0).submatches.Count - 1 Arr(Index, j + 1) = "'" & Mh.Item(0).submatches(j) Debug.Print Index; " "; Arr(Index, j + 1) Next j End If End If End If wdDoc.Close False NextDocument: On Error GoTo 0 Next n wdApp.Quit With Sht Set Rng = .Range("A2") Set Rng = Rng.Resize(UBound(Arr), UBound(Arr, 2)) Rng.Value = Arr End With Set Wb = Nothing Set Sht = Nothing Set Rng = Nothing Set wdApp = Nothing Set wdDoc = Nothing End Sub Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String() Dim Arr() As String Dim FSO As Object Dim ThisFolder As Object Dim OneFile As Object ReDim Arr(1 To 1) Arr(1) = "None" Dim Index As Long Index = 0 Set FSO = CreateObject("Scripting.FileSystemObject") On Error GoTo ErrorExit Set ThisFolder = FSO.getfolder(FolderPath) If Err.Number <> 0 Then Exit Function For Each OneFile In ThisFolder.Files If OneFile.Name Like Pattern Then If Len(ComplementPattern) > 0 Then If Not OneFile.Name Like ComplementPattern Then Index = Index + 1 ReDim Preserve Arr(1 To Index) Arr(Index) = OneFile.Path '& OneFile.Name End If Else Index = Index + 1 ReDim Preserve Arr(1 To Index) Arr(Index) = OneFile.Path '& OneFile.Name End If End If Next OneFile ErrorExit: FsoGetFiles = Arr Erase Arr Set FSO = Nothing Set ThisFolder = Nothing Set OneFile = Nothing End Function