VBA遍历文件夹并正则表达式匹配文本所在位置

写这个是为了减轻重复的检索工作

Option Explicit'遍历文件，利用正则表达式寻找匹配的字符串Sub test()    Dim MyName, Dic, Did, i, T, F, TT, MyFileName, Ke, Sh, mMatches, mRegExp    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象    Set Did = CreateObject("Scripting.Dictionary")  '用来保存结果    Set mRegExp = CreateObject("vbscript.regexp") '正则表达式对象    Dic.Add ("D:\temp\"), ""  '要检索的目录    With mRegExp        .Global = True                              'True表示匹配所有, False表示仅匹配第一个符合项        .IgnoreCase = True                          'True表示不区分大小写, False表示区分大小写        .Pattern = "([^(\.|\r\n)]{1}abc|[^(\.|\r\n)]{1}haha|[^(\.|\r\n)]{1}xixi)"   '匹配字符模式    End With    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    Did.Add ("匹配处"), ""    '以查找D盘temp下所有TXT文件为例    For Each Ke In Dic.keys         Dim txt As String         MyFileName = Dir(Ke & "*.txt")         If MyFileName <> "" Then            Open (Ke & MyFileName) For Input As #1                Dim count_i '定义一个遍历计算行数                count_i = 0                Do While Not EOF(1)                   Line Input #1, txt 'txt即读取的一行文本                   count_i = count_i + 1 '计算行数                    If mRegExp.test(txt) Then                        Did.Add (Ke & MyFileName & "   " & count_i), "" '匹配处的文件路径和行数                    End If               Loop             Close #1          End If    Next    '下面的代码是删除已有的表，重新创建并存入结果    For Each Sh In ThisWorkbook.Worksheets        If Sh.Name = "结果" Then            Sheets("结果").Cells.Delete            F = True            Exit For        Else            F = False        End If    Next    If Not F Then        Sheets.Add.Name = "结果"    End If    Sheets("结果").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)End Sub

针对需要匹配多个正则表达式时的改进

Option Explicit'遍历文件，利用正则表达式寻找匹配的字符串Sub test()    Dim MyName, Dic, Did, i, F, MyFileName, Ke, Sh, mMatches, mRegExp, targets, target    Set targets = Range("A1:A3") '目标区域    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象    Dic.Add ("D:\temp\"), ""  '要检索的目录    Set mRegExp = CreateObject("vbscript.regexp") '正则表达式对象    With mRegExp            .Global = True                          'True表示匹配所有, False表示仅匹配第一个符合项            .IgnoreCase = True                      'True表示不区分大小写, False表示区分大小写    End With    '下面是遍历文件目录    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    '下面是根据不同的正则表达式去匹配结果，并分别保存到一个sheet中    For Each target In targets        Set Did = CreateObject("Scripting.Dictionary")  '用来保存结果        mRegExp.Pattern = "[^(\.|\r\n)]{1}" & target.Value  '需要匹配的正则表达式        Did.Add ("匹配处"), ""    '以查找D盘temp下所有html文件为例        For Each Ke In Dic.keys             Dim txt As String             MyFileName = Dir(Ke & "*.html") '指定文件后缀             If MyFileName <> "" Then                Open (Ke & MyFileName) For Input As #1                    Dim count_i '定义一变量记录行数                    count_i = 0                    Do While Not EOF(1)                       Line Input #1, txt 'txt即读取的一行文本                       count_i = count_i + 1 '行数+1                        If mRegExp.test(txt) Then                            Did.Add (Ke & MyFileName & "   " & count_i), "" '匹配处的文件路径和行数                        End If                   Loop                 Close #1              End If        Next        '下面的代码是删除已有的表，重新创建并存入结果        For Each Sh In ThisWorkbook.Worksheets            If Sh.Name = ("结果" & target.Value) Then                Sheets("结果" & target.Value).Cells.Delete                F = True                Exit For            Else                F = False            End If        Next        If Not F Then            Sheets.Add.Name = "结果" & target.Value        End If        Sheets("结果" & target.Value).[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)    NextEnd Sub