ZiGma

【VBA】VBA+正则表达式提取标题快速保存归档

VBA
字数统计: 1,661阅读时长: 8 min
2017/08/26 Share

今天快下班了同事找我提了个需求：归档目录太深，每次写完材料归档时需要点很久，且文件夹繁多，保存时要新建文件夹并重命名，Word文档保存时也需要命名。

想了一下，可以靠Word宏配合正则表达式解决。

思路：利用正则表达式提取正文中的案号，并将该案号作为归档文件夹和文件名。而且正好之前在Excel中试验过类似功能，只不过那个是提取案号后将Word另存为。

注：需要在VBA编辑器工具→引用Microsoft VBScript Regular Expressions 5.5

Word代码如下：

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
Sub 快速保存()
Path1 = "E:\" "设置文件夹路径
    Set objshell = CreateObject("Shell.Application") 
    Set objFolder = objshell.browseForFolder(0, "选择文件夹", 0, Path1)
    If Not objFolder Is Nothing Then FolderPath = Path1 & objFolder

    Dim myExp As RegExp
    Dim AllContent
    Set myExp = New RegExp
    AllContent = ActiveDocument.Content
    With myExp  '利用正则表达式提取案号以作为文件夹名和文件名'
        .Pattern = "(（2|\(2).+?号"
        .Global = False
        Set myMsg = .Execute(AllContent)

        For Each m In myMsg
            filename_ = m
        Next
    End With
    Set wdApp = Nothing

    Path2 = FolderPath & "\" & filename_ "判断是否已经存在文件
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(Path2) = True Then
        If (MsgBox("已存在该文件，是否覆盖？", vbYesNo)) = vbNo Then
            Cancel = True
            GoTo k
        Else
            GoTo l
        End If
    Else
        MkDir (FolderPath & "\" & filename_) "不存在则创建文件夹
    End If
l:
    ActiveDocument.SaveAs FileName:=FolderPath & "\" & filename_ & "\" & filename_
k:
End Sub

2018-2-4日更新 进入2018年同事又提出要更改年份文件夹，因此修改了代码，保存到相应案号的年份中。

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
Sub 快速保存()
    Dim myExp As RegExp '利用正则表达式提取案号以作为文件夹名和文件名'
    Dim AllContent
    Set myExp = New RegExp
    AllContent = ActiveDocument.Content
    With myExp
        .Pattern = "(（2|\(2).+?号" '正则表达式'
        .Global = False
        Set myMsg = .Execute(AllContent)

        For Each m In myMsg
            fileName_ = m
        Next
    End With

    Year_ = Mid(fileName_, 2, 4) & "年案件"

    Path1 = "E:\" "设置文件夹路径
    Set objshell = CreateObject("Shell.Application") '选择保存路径'
    Set objFolder = objshell.browseForFolder(0, "选择文件夹", 0, Path1)
    If Not objFolder Is Nothing Then FolderPath = Path1 & objFolder Else Exit Sub

    Path2 = FolderPath & "\" & Year_ "定义年份及案号命名的文件夹路径
    Path3 = FolderPath & "\" & Year_ & "\" & fileName_
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(Path2) = False Then
        MkDir (FolderPath & "\" & Year_) "不存在则创建文件夹
    End If

    If FSO.FolderExists(Path3) = True Then
        If (MsgBox("已存在该文件，是否覆盖？", vbYesNo)) = vbNo Then
            Cancel = True
            Exit Sub
        Else
            GoTo l
        End If
    Else
    MkDir (FolderPath & "\" & Year_ & "\" & fileName_)
    End If
l:
    ActiveDocument.SaveAs FileName:=FolderPath & "\" & Year_ & "\" & fileName_ & "\" & fileName_ "另存为重命名文件
End Sub

2018-2-5日更新

发现每次需要进入宏来修改路径太麻烦，所以又更新了代码，在C盘生成一个保存路径的TXT文件作为配置读取，并且无需再在使用前引用Microsoft VBScript Regular Expressions 5.5。

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
Sub 设置保存路径()
    Dim sFile, sFile_, sOpen As Object, Fso As Object
    Dim FPath As String
    Set Fso = CreateObject("Scripting.FileSystemObject")

    If Fso.FileExists("C:\AutoSave\AutoSave.txt") = False Then "判断是否存在设置文件"
        MkDir ("C:\AutoSave\") "创建设置文件夹及文件
        Set sFile = Fso.CreateTextFile("C:\AutoSave\AutoSave.txt", True)
        Set sFile_ = Fso.CreateTextFile("C:\AutoSave\自动保存宏设置文件夹，勿删.txt", True)
        Set sFile = Nothing
        Set sFile_ = Nothing
    End If

    Set objshell = CreateObject("Shell.Application") '设置保存路径'
    Set objFolder = objshell.browseForFolder(0, "请选择保存路径", 0, 0)
    If Not objFolder Is Nothing Then FPath = objFolder.self.Path Else Exit Sub '必要！判断是否取消保存'

    Set sOpen = Fso.OpenTextFile("C:\AutoSave\AutoSave.txt", 2, 0) '写入保存的路径'
    If len(FPath) <= 3 then '判断是否选取了盘符根目录'
        sOpen.Write FPath
    Else
        sOpen.Write FPath & "\" "写入设置的路径
    End if
    sOpen.Close

    Set Fso = Nothing
    Set sOpen = Nothing
    Set objshell = Nothing
    Set objFolder = Nothing
End Sub

Sub 快速保存()
    Dim sFile, sFile_, sOpen As Object, Fso As Object
    Dim FPath As String
    Dim myExp As RegExp '利用正则表达式提取案号以作为文件夹名和文件名'
    Dim AllContent

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set objshell = CreateObject("Shell.Application")

    If Fso.FileExists("C:\AutoSave\AutoSave.txt") = False Then '判断是否存在设置文件'

        If (MsgBox("未设置归档路径，是否设置？", vbYesNo)) = vbNo Then
            Cancel = True
            Exit Sub
        Else
            Set objFolder = objshell.browseForFolder(0, "请选择保存路径", 0, 0) '设置保存路径'
            If Not objFolder Is Nothing Then FPath = objFolder.self.Path Else Exit Sub '必要！判断是否取消设置'

            MkDir ("C:\AutoSave\") "创建设置文件夹及文件
            Set sFile = Fso.CreateTextFile("C:\AutoSave\AutoSave.txt", True)
            Set sFile_ = Fso.CreateTextFile("C:\AutoSave\自动保存宏设置文件夹，勿删.txt", True)
            Set sFile = Nothing
            Set sFile_ = Nothing

            Set sOpen = Fso.OpenTextFile("C:\AutoSave\AutoSave.txt", 2, 0) 
            If len(FPath) <= 3 then '判断是否选取了盘符根目录'
                sOpen.Write FPath
            Else
                sOpen.Write FPath & "\" "写入设置的路径
            End if
            sOpen.Close
        End If

        Set sOpen = Nothing
        Set objFolder = Nothing
    End If​
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
    Set myExp = New RegExp
    AllContent = ActiveDocument.Content
    With myExp
        .Pattern = "(（2|\(2).+?号" '正则表达式'
        .Global = False
        Set myMsg = .Execute(AllContent)

        For Each m In myMsg
            fileName_ = m
        Next
    End With

    Year_ = Mid(fileName_, 2, 4) & "年案件" '提取年度，并依据年度分类文件'

    Open "C:\AutoSave\AutoSave.txt" For Input As #1
    Line Input #1, Path1
    Close #1

    Set objFolder = objshell.browseForFolder(0, "请选择案件类型文件夹", 0, Path1) '选择保存路径'
    If Not objFolder Is Nothing Then FolderPath = objFolder.self.Path Else Exit Sub '必要！判断是否取消保存'

    Path2 = FolderPath & "\" & Year_ "定义年份及案号命名的文件夹路径
    Path3 = FolderPath & "\" & Year_ & "\" & fileName_
    If Fso.FolderExists(Path2) = False Then
        MkDir (FolderPath & "\" & Year_) "创建年份的文件夹
    End If

    If Fso.FolderExists(Path3) = True Then
        If (MsgBox("已存在该文件，是否覆盖？", vbYesNo)) = vbNo Then
            Cancel = True
            Exit Sub
        Else
            GoTo l
        End If
    Else
        MkDir (FolderPath & "\" & Year_ & "\" & fileName_)
    End If
l:
    ActiveDocument.SaveAs FileName:=FolderPath & "\" & Year_ & "\" & fileName_ & "\" & fileName_ "另存为重命名文件
End Sub

Excel中则需要调用Word.Application，但是思路还是和Word中一样。

代码如下：

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
Sub test()
    Dim wdApp As Word.Application
    Dim wddocument As Word.document
    Dim myExp As RegExp
    Dim AllContent
    For k = 2 To Application.CountA(Sheet1.Range("D:D"))
        file_ = Sheet1.Range("D" & k)
        Set wdApp = New Word.Application
        Set wddocument = wdApp.Documents.Open(file_)
        With wdApp
            Set myExp = New RegExp
            AllContent = wddocument.Content
            With myExp
                .Pattern = Sheet1.Range("B1")
                .Global = False
                Set myMsg = .Execute(AllContent)

                For Each m In myMsg
                    Sheet1.Range("E" & k) = m
                Next
            End With
            .Documents.Close
            .Quit
        End With
        Set wdApp = Nothing
    Next
End Sub

原文作者：ZiGma

原文链接：http://www.zigma.cc/2017/08/26/【VBA】VBA+正则表达式提取标题快速保存归档/

发表日期：August 26th 2017, 11:05:35 pm

更新日期：July 26th 2018, 11:59:48 pm

版权声明：本文采用知识共享署名-非商业性使用 4.0 国际许可协议进行许可

CATALOG
  1. 1. Word代码如下：
  2. 2. 代码如下：
Total : 29
2020
2019
2018
2017
JSBox Hexo VPS 搬瓦工 CentOS VBA Python 皮肤 iOS 旅行 杂物 照片 瞎折腾 WIN10 合同 民间借贷 PotPlayer 落格 Wordpress
JSBox VPS VBA Python 旅行 瞎折腾 工作 Potplayer皮肤 App Wordpress