20170922xlVBA_GetCellTextFromWordDocument

Posted 2020-10-08 Excel VBA 小天地

Sub GetCellTextFromWordDocument()
    ‘应用程序设置
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    ‘错误处理
    ‘On Error GoTo ErrHandler
    
    ‘计时器
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    
    ‘变量声明
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range
    ‘Dim Arr As Variant
    Dim i As Long
    Dim EndRow As Long
    
    ‘实例化对象
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("提取信息")
    With Sht
        .UsedRange.Offset(1).ClearContents
    End With
    
    Dim FolderPath As String
    Dim FileName As String
    Dim Tb As Word.Table
    Dim FileCount As Long
    Dim WdApp As Word.Application
    Dim OpenDoc As Word.Document
    Dim wdRng As Object
    Dim Arr() As String
    ReDim Arr(1 To 10, 1 To 1)
    index = 0
    
    FolderPath = Wb.Path & "\文档1\"    ‘此处填入路径
    FileName = Dir(FolderPath & "*.doc*")
    FileCount = 0
    Set WdApp = New Word.Application
    ‘WdApp.Visible = True
    Do While FileName <> ""
        Debug.Print FileName
        FileCount = FileCount + 1
        
        Set OpenDoc = WdApp.Documents.Open(FolderPath & FileName)
        For Each Tb In OpenDoc.Tables
            If Tb.Cell(1, 1).Range.Text Like "*序号*" Then
                index = index + 1
                ReDim Preserve Arr(1 To 10, 1 To index)
                With Tb
                    Arr(1, index) = RepSymbol(.Cell(3, 4).Range.Text)
                    Arr(2, index) = RepSymbol(.Cell(24, 3).Range.Text)  ‘父姓名
                    Arr(3, index) = RepSymbol(.Cell(25, 4).Range.Text)  ‘父地址
                    Arr(4, index) = "‘" & RepSymbol(.Cell(27, 3).Range.Text)  ‘父电话
                    Arr(5, index) = RepSymbol(.Cell(29, 3).Range.Text)  ‘母姓名
                    Arr(6, index) = RepSymbol(.Cell(30, 4).Range.Text)  ‘母地址
                    Arr(7, index) = "‘" & RepSymbol(.Cell(32, 3).Range.Text)   ‘母电话
                    Arr(8, index) = RepSymbol(.Cell(10, 4).Range.Text)  ‘户地址
                    Arr(9, index) = RepSymbol(.Cell(14, 4).Range.Text)  ‘现地址
                    Arr(10, index) = RegGet(FileName, "(\d+)")
                End With
            End If
        Next Tb
        OpenDoc.Close True
        
        With Sht
            EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
            Set Rng = .Cells(EndRow, 1)
            Set Rng = Rng.Resize(UBound(Arr, 2), UBound(Arr))
            Rng.Value = Application.WorksheetFunction.Transpose(Arr)
        End With
        FileName = Dir
    Loop
    
    ‘WdApp.Quit
    
UsedTime = VBA.Timer - StartTime
    Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
   ‘MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")

ErrorExit:                    ‘错误处理结束，开始环境清理
    Set Wb = Nothing
    Set Sht = Nothing
    Set Rng = Nothing
    Set WdApp = Nothing
    Set OpenDoc = Nothing
    
    
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "错误提示！"
        ‘Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub

Function RepSymbol(ByVal Text As String) As String
    Dim NewText As String
    NewText = Text
    NewText = Replace(NewText, vbTab, "")
    NewText = Replace(NewText, vbCr, "")
    NewText = Replace(NewText, vbLf, "")
    NewText = Replace(NewText, vbCrLf, "")
    NewText = Replace(NewText, "", "")
    RepSymbol = NewText
End Function
Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String
‘传递参数 ：原字符串， 匹配模式
    Dim Regex As Object
    Dim Mh As Object
    Set Regex = CreateObject("VBScript.RegExp")
    With Regex
        .Global = True
        .Pattern = Pattern
    End With
    If Regex.test(OrgText) Then
        Set Mh = Regex.Execute(OrgText)
        RegGet = Mh.Item(0).submatches(0)
    Else
        RegGet = ""
    End If
    Set Regex = Nothing
End Function