提取多个Word文档指定位置内容到Excel表格

yusanli · 发表于 2021-2-19 17:02

有上千个Word文档，格式一模一样。我看了很多论坛案例，试着修改了代码，可是还是得不到想要的结果，各位大神请帮忙写一下VBA代码，感谢感谢。

skyzxh · 发表于 2021-2-19 17:52

得分析规律，再写vba吧？。。。。。。。。。。。。。。。。。

wanghongfei · 发表于 2021-2-19 20:49

Sub 打开Word()
Application.ScreenUpdating = False
Set doc = CreateObject("word.application")
Set wok = ThisWorkbook
f = Dir(ThisWorkbook.Path & "\*.doc")
x = 7
Do While f <> ""
Set wd = doc.documents.Open(ThisWorkbook.Path & "" & f)
doc.Visible = True
With wok.Sheets(1)
Cells(x, 1) = wd.Paragraphs(2).Range.Text
Cells(x, 2) = Split(wd.Paragraphs(4).Range.Text, "：")(1)
Cells(x, 3) = Split(wd.Paragraphs(6).Range.Text, "：")(1)
Cells(x, 4) = Split(wd.Paragraphs(5).Range.Text, "：")(1)
m = InStr(wd.Paragraphs(7).Range.Text, "）")
n = InStr(wd.Paragraphs(7).Range.Text, "（")
Cells(x, 5) = Mid(wd.Paragraphs(7).Range.Text, n + 1, m - 1)
Cells(x, 6) = Split(wd.Paragraphs(9).Range.Text, "：")(1)
Cells(x, 7) = wd.Paragraphs(14).Range.Text
x = x + 1
End With
f = Dir
wd.Close False
Loop
doc.Quit
[e:f].Replace "。", ""
[d:g].Replace " ", ""
[e:f].Replace "）", ""
MsgBox "完成！"
Application.ScreenUpdating = False
End Sub

复制代码

wang-way · 发表于 2021-2-20 14:12

练练手

Public Sub wang_way()
'作者 DG_NextSeven
'日期 2021-02-20
Dim Wb As Workbook
Dim Sht As Worksheet
Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets(1)
Sht.UsedRange.Offset(1).Clear
FolderPath = Wb.Path & ""
filepaths = FsoGetFiles(FolderPath, "*.doc*")
If filepaths(1) = "NULL" Then Exit Sub
Dim wdApp As Object
Dim doc As Object
Set Regex = CreateObject("VBScript.RegExp")
With Regex
.Global = True
.Pattern = "(中劳鉴2020年\d+号)(?:[\d\D]*?)被鉴定人：([\d\D]+?)\s*?\r(?:[\d\D]*?)身份证号：([\d\D]+?)\s*?\r(?:[\d\D]*?)工作单位：([\d\D]+?)\s*?\r(?:[\d\D]*?)" & _
"见《工伤认定决定书》（([\d\D]+?)）(?:[\d\D]*?)鉴定结论为：([\d\D]+?)。(?:[\d\D]*?)\D(\d+年\d+月\d+日)"
.MultiLine = False
'.IgnoreCase = False
End With
Set wdApp = CreateObject("word.application")
i = 1
For Each filepath In filepaths
Set doc = wdApp.documents.Open(filepath)
s = doc.Range.Text
If Regex.Test(s) Then
i = i + 1
Set Mh = Regex.Execute(s)
j = 0
For Each sb In Mh(0).submatches
j = j + 1
Sht.Cells(i, j).Value = "'" & sb
Next sb
End If
doc.Close
Next
wdApp.Quit
Set Wb = Nothing
Set Sht = Nothing
Set Regex = Nothing
Set wdApp = Nothing
Set doc = Nothing
Set Mh = Nothing
MsgBox "提取完成！"
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) = "NULL"
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
End If
Else
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path
End If
End If
Next OneFile
ErrorExit:
FsoGetFiles = Arr
Erase Arr
Set FSO = Nothing
Set ThisFolder = Nothing
Set OneFile = Nothing
End Function

复制代码

yusanli · 发表于 2021-2-22 10:57

wanghongfei 发表于 2021-2-19 20:49

大神，报错啊，自动化（automation）错误

yusanli · 发表于 2021-2-22 10:59

wang-way 发表于 2021-2-20 14:12
练练手

感谢老师，问题解决了，但是有个小问题，运行速度有点慢，在运行过程中，其实数据早就提取好了，但是后期一直在转圈圈等待时间很久。

wang-way · 发表于 2021-2-22 22:16

本帖最后由 wang-way 于 2021-2-24 00:44 编辑

yusanli 发表于 2021-2-22 10:59
感谢老师，问题解决了，但是有个小问题，运行速度有点慢，在运行过程中，其实数据早就提取好了，但是后期 ...

换个方案试试

复制代码

yusanli · 发表于 2021-2-23 08:39

wang-way 发表于 2021-2-22 22:16
换个方案试试

感谢感谢！

jjmysjg · 发表于 2021-2-23 09:05

yusanli 发表于 2021-2-22 10:57
大神，报错啊，自动化（automation）错误

代码被屏蔽了\

lhysina · 发表于 2022-8-2 15:33

wang-way 发表于 2021-2-22 22:16
换个方案试试

怎么没有显示

		自动登录	找回密码
密码			免费注册

[求助] 提取多个Word文档指定位置内容到Excel表格

评分