VBA Find all regEx matches in array - excel

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.
I want to exclude all items that do not start with letters. startPattern = "(^[A-Z]{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 "[A-Z][A-Z]" 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