本帖最后由 zxsea_7426 于 2022-8-23 19:37 编辑
正则果然强大,我还在笨笨的一个一个提取，效率真是差距啊。
Sub 数据提取()
Call Read_Word_1
Call 分离数据
End Sub
Sub Read_Word_1()
' Application.ScreenUpdating = False
' On Error Resume Next
Dim worDoc As Object
Dim wordappl As Object
Dim mydoc As String
Dim myappl As String
mydoc = ThisWorkbook.path & "\新和平小区1类（终审版）.docx" '本文档目录下的doc文件，这里可以直接改成路径+文件名的形式
Set wordappl = CreateObject("Word.application") '设置wordappl对象
Set worDoc = wordappl.Documents.Open(mydoc) '打开word文档，mydoc变量指定路径和文件名
worDoc.Activate '激活打开的文档
wordappl.Selection.WholeStory '全选文档
wordappl.Selection.Copy '复制选择内容到剪贴板
worDoc.Application.Quit '关闭word文档
Set wordapp = Nothing '释放对象变量的内存
Workbooks(1).Sheets(2).Activate '激活excel第一个工作簿的第二个工作表
ActiveSheet.UsedRange.Clear '把当前工作表清空，如果有重要数据，这条删除
Cells(1, 1).Select '选择A1单元格
ActiveSheet.Paste '粘贴复制的内容
' wordappl.Quit
Set wordappl = Nothing
' Application.ScreenUpdating = True
End Sub
Sub 分离数据()
With Sheet2
r = .[a1048576].End(3).Row
Ar = .Range(.[a1], .Cells(r, 1))
For i = 1 To UBound(Ar)
If Trim(Ar(i, 1)) <> "" Then
ss = ss & Trim(Ar(i, 1))
End If
Next i
Arr = Split(ss, "催费通知单")
ReDim ar1(1 To UBound(Arr), 1 To 8)
For i = 1 To UBound(Arr)
a_1 = InStr(Arr(i), ")")
ar1(i, 1) = Replace(Replace(Trim(Left(Arr(i), a_1)), " ", " "), " ", " ")
ar1(i, 1) = Replace(ar1(i, 1), "( ", "(")
ar1(i, 1) = Replace(ar1(i, 1), " )", ")")
a2 = Split(Arr(i), "您（拥有/居住）的")
a_2_1 = InStr(a2(1), "小区") - 1
ar1(i, 2) = Replace((Left(a2(1), a_2_1)), " ", "")
a_2_2 = InStr(a2(1), "小区") + 2
If InStr(a2(1), "期") > 0 And InStr(a2(1), "期") < 100 Then
A_3 = InStr(a2(1), "期") - 1
ar1(i, 3) = Replace(Mid(a2(1), a_2_2, A_3 - a_2_2), " ", "")
If InStr(a2(1), "楼") > 0 Then
A_4 = InStr(a2(1), "楼") - 1
ElseIf InStr(a2(1), "栋") > 0 Then
A_4 = InStr(a2(1), "栋") - 1
End If
ar1(i, 4) = Replace(Mid(a2(1), A_3 + 2, A_4 - A_3), " ", "")
a_5 = InStr(a2(1), "号") - 1
ar1(i, 5) = Replace(Mid(a2(1), A_4 + 2, a_5 - A_4 - 1), " ", "")
ElseIf InStr(a2(1), "栋") > 0 And InStr(a2(1), "栋") < 100 Then
A_3 = InStr(a2(1), "栋") - 1
ar1(i, 3) = Replace(Mid(a2(1), a_2_2, A_3 - a_2_2), " ", "")
If InStr(a2(1), "单元") > 0 Then
A_4 = InStr(a2(1), "单元") - 1
End If
ar1(i, 4) = Replace(Mid(a2(1), A_3 + 2, A_4 - A_3 + 1), " ", "")
a_5 = InStr(a2(1), "号") - 1
ar1(i, 5) = Replace(Mid(a2(1), A_4 + 2 + 1, a_5 - A_4 - 1), " ", "")
End If
a_money = Split(a2(1), "欠费")
ar1(i, 6) = Val(Replace(Left(a_money(1), InStr(a_money(1), "元") - 1), " ", ""))
ar1(i, 8) = Val(Replace(Left(a_money(3), InStr(a_money(3), "元") - 1), " ", ""))
a_money_1 = Split(a2(1), "滞纳金")
ar1(i, 7) = Val(Replace(Left(a_money_1(1), InStr(a_money(1), "元") - 1), " ", ""))
Next i
ActiveSheet.DrawingObjects.Select '删除所有对象
Selection.Delete
Sheet2.UsedRange.Clear
Sheet2.[a1].Resize(1, 8) = Array("编码", "项目名称", "第几期", "楼栋", "房号", "欠费", "滞纳金", "合计欠费")
Sheet2.[a2].Resize(UBound(Arr), 8) = ar1
Sheet2.[a2].Resize(UBound(Arr), 8).EntireColumn.AutoFit
End With
End Sub
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-8-23 16:13
楼主
