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

  

05-22 10:41
查看更多