时间戳

首页 > 解决方案 > VBA 在数组中查找所有正则表达式匹配项

excel - VBA 在数组中查找所有正则表达式匹配项

问题描述

我有一个很大的列表，想要找到相同项目名称的所有条目。

我的数据如下所示：

一个标题 另一个标题 项目名称
第一的 第 1 行 AA_Bla_ABCDEF _
第二 废话 XY_Blah_ ABCDEF
第四 又是这个项目名称 AA_Bla_ABCDEF _
第三 布鲁布 12_Blubb_ABCDEF

因此，我有这段代码，它获取所有可能的过滤条件（项目名称）：

lastRow = Range(CStr("C" & ActiveSheet.Rows.Count)).End(xlUp).Row

Dim data(), dict As Object, r As Long
Set dict = CreateObject("Scripting.Dictionary")

data = ActiveSheet.Range("C2", "C" & CStr(lastRow)).Columns(1).Value

For r = 1 To UBound(data)
    dict(data(r, 1)) = Empty
Next

data = WorksheetFunction.Transpose(dict.keys())
End Sub

我可以访问项目名称列表，例如：

Debug.Print data(1, 1) ' AA_Bla_ABCDEF
Debug.Print data(2, 1) ' XY_Blah_ABCDEF  
Debug.Print data(3, 1) ' 12_Blubb_ABCDEF

现在，我想搜索data所有满足特定条件的条目。

  1. 我想排除所有不以字母开头的项目。startPattern = "(^[A-Z]{2})"
  2. 我想在所有剩余的项目中找到最后 6 个符号（数字、字符、下划线......）相同的项目projectPattern = "(.$){6}" 因此，我想到了 regEx 并尝试了：
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp") ' Automatic reference binding

    For r = 1 To UBound(data)

        With regEx
            .Global = True
            .MultiLine = True
            .IgnoreCase = False
            .Pattern = projectPattern 
        End With

    ' If data.find(regEx).count > 1 (if I have this pattern more than once)
         ' similarEntries = data.find(regEx) ...

如何在数组中搜索多次出现的所有匹配项？在示例列表中，它只会是：AA_Bla_ ABCDEF

标签： excelregexvbamultidimensional-array

解决方案

用于LIKE "[A-Z][A-Z]"排除某些项目并RIGHT(string,6)作为字典键来计算重复项。

Option Explicit

Sub Macro1()

    Dim ws As Worksheet
    Dim dict As Object, name As String, key, ar
    Dim r As Long, lastrow As Long
   
    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
   
    lastrow = ws.Cells(Rows.Count, "C").End(xlUp).Row
    For r = 2 To lastrow
        name = Trim(ws.Cells(r, "C"))
        If UCase(Left(name, 2)) Like "[A-Z][A-Z]" Then
            key = Right(name, 6)
            If dict.exists(key) Then
                dict(key) = dict(key) & vbTab & name
            Else
                dict(key) = name
            End If

        End If
    Next

    ' show results on sheet2
    r = 1
    For Each key In dict
        ar = Split(dict(key), vbTab)
        If UBound(ar) > 0 Then
            Sheet2.Cells(r, 1) = key
            Sheet2.Cells(r, 2) = UBound(ar) + 1
            Sheet2.Cells(r, 3).Resize(1, UBound(ar) + 1) = ar
            r= r + 1
        End If
    Next
End Sub

推荐阅读