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
时间: 2024-11-05 17:26:36