20171022xlVBA练手提取入所记录

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