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

Question

I have a large list and want to find all entries for the same project names.

My data looks like this:

A header	Another header	Project names
First	row1	AA_Bla_ ABCDEF
Second	Blah	XY_Blah_ ABCDEF
Fourth	Again this project name	AA_Bla_ ABCDEF
Third	Blubb	12_Blubb_ABCDEF

Therefore, I have this code, which gets all the possible filter criteria (Project names):

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

I can access the list of project names like:

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

Now, I would like to search in data for all entries that fulfill certain criteria.

1. I want to exclude all items that do not start with letters. startPattern = "(^[AZ]{2})"
2. I want to find in all remaining items those who have the same last 6 symbols (numbers, chars, underscores...) projectPattern = "(.$){6}" Therefore, I thought of regEx and tried:

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) ...

How can I search the array for all matches that occur more than once? In the example list it would be only: AA_Bla_ ABCDEF

Answer 1

Using LIKE "[AZ][AZ]" to exclude some items and RIGHT(string,6) as dictionary key to count duplicates.

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