ZiGma

【VBA】利用VBA提取内容并生成新文件

字数统计: 982阅读时长: 5 min
2017/09/27 Share

前言

工作中一直需要根据一个Word文件内的内容提取后放到其他Word模板中整合为一个新的文件,数量一多就很烦,所以利用VBA写了一个工具,利用正则表达式来提取指定文件的内容并根据既定的模板生成新文件。

Excel各项目布局

Excel1

B列为正则表达式,根据不同的提取部位进行编辑。 C列为模板文档位置。 D列为需要提取文件的目录。 E、F、G、H、I列为提取的内容。

代码如下:

获取需要提取的文件路径

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub getfile()
Dim Myname, Dic, Did, i, t, F, MyFileName
Set objshell = CreateObject("Shell.Application")
Set objFolder = objshell.browseForFolder(0, "选择文件夹", 0, 0) '选择需要遍历的文件夹'
If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\" Else Exit Sub '如果选择了文件夹则输出文件夹的路径'
Set objFolder = Nothing
Set objshell = Nothing

Set Dic = CreateObject("Scripting.Dictionary") '设置字典'
Set Did = CreateObject("Scripting.Dictionary")
Dic.Add (lj), "" '将路径添加到Dic字典'
i = 0
Do While i < Dic.Count
ke = Dic.keys
Myname = Dir(ke(i), vbDirectory)
Do While Myname <> ""
If Myname <> "." And Myname <> ".." Then
If (GetAttr(ke(i) & Myname) And vbDirectory) = vbDirectory Then
Dic.Add (ke(i) & Myname & "\"), ""
End If
End If
Myname = Dir
Loop
i = i + 1
Loop
For Each m In Dic.keys
Did.Add (m), ""
Next
For Each ke In Dic.keys
MyFileName = Dir(ke & "*.doc")
Do While MyFileName <> ""
Did.Add (ke & MyFileName), ""
MyFileName = Dir
Loop
Next

Sheet1.Range("D:I").ClearContents
Sheet1.[D1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
End Sub

提取内容

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Sub 管辖提取()
Dim wdApp As Word.Application
Dim wddocument As Word.Document
Dim myExp1, myExp2, myExp3, myExp4, myExp5 As RegExp
Dim AllContent
Max_k = Application.CountA(Sheet1.Range("D:D"))
For k = 2 To Max_k
file_ = Sheet1.Range("D" & k)
Set wdApp = New Word.Application
Set wddocument = wdApp.Documents.Open(file_)
With wdApp
Set myExp1 = New RegExp
Set myExp2 = New RegExp
Set myExp3 = New RegExp
Set myExp4 = New RegExp
Set myExp5 = New RegExp
AllContent = wddocument.Content
With myExp1 '提取上诉人'
.Pattern = Sheet1.Range("B1")
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
Sheet1.Range("E" & k) = Mid(m, 3, (Len(m) - 3))
Next
End With

With myExp2 '提取起诉'
.Pattern = Sheet1.Range("B2")
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
Sheet1.Range("F" & k) = Mid(m, 6, (Len(m) - 10))
Next
End With

With myExp3 '提取上诉'
.Pattern = Sheet1.Range("B3")
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
Sheet1.Range("G" & k) = m
Next
End With

With myExp4 '提取案号'
.Pattern = Sheet1.Range("B4")
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
Sheet1.Range("H" & k) = m
Next
End With

With myExp5 '提取时间'
.Pattern = Sheet1.Range("B5")
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
Sheet1.Range("I" & k) = m
Next
End With

With Show1
.Show 0
.Caption = "正在提取……"
.Label1.Caption = "正在提取 " & (k - 1) & "/" & (Max_k - 1)
.Label2.Caption = Sheet1.Range("H" & k)
DoEvents
End With

.Documents.Close
.Quit
End With
Set wdApp = Nothing
Next
Show1.Hide
End Sub

为直观了解提取和生成进度,需要添加窗体控件。

Excel2

生成文件

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub 管辖生成()
Dim wdApp As Word.Application
Dim wddocument As Word.Document
Max_k = Application.CountA(Sheet1.Range("D:D"))
If (MsgBox("确认生成?", vbYesNo)) = vbNo Then
Cancel = True
Else
For k = 2 To Max_k
file_ = Sheet1.Range("C1")
Set wdApp = New Word.Application
Set wddocument = wdApp.Documents.Open(file_)
With wdApp
wddocument.Content.Find.Execute findtext:="NUM", ReplaceWith:=Range("H" & k)
wddocument.Content.Find.Execute findtext:="TIME", ReplaceWith:=Range("I" & k)
wddocument.Content.Find.Execute findtext:="QS", ReplaceWith:=Range("F" & k), replace:=wdReplaceAll
wddocument.Content.Find.Execute findtext:="SS", ReplaceWith:=Range("E" & k) & Range("G" & k)
Filename = Sheet1.Range("D1") & Sheet1.Range("H" & k) & "管辖合议笔录"
.ActiveDocument.SaveAs Filename
With Show1
.Show 0
.Caption = "正在生成……"
.Label1.Caption = "正在生成 " & (k - 1) & "/" & (Max_k - 1)
.Label2.Caption = Sheet1.Range("H" & k) & "管辖合议笔录.doc"
DoEvents
End With
.Documents.Close
.Quit
End With
Set wdApp = Nothing
Next
Show1.Hide
End If
End Sub
CATALOG
  1. 1. 前言
  2. 2. Excel各项目布局
  3. 3. 代码如下:
    1. 3.1. 获取需要提取的文件路径
    2. 3.2. 提取内容
    3. 3.3. 生成文件