Adding pattern data to the collection and copying rows from the collection to different files - excel

Question

I had the task to extract the table and match the abbreviations in the "Number" column with the list of companies. For example: copy all the rows where "KP00000221" is written in the Number column and put it in a separate file. The same should be done for "VT", "AK" and so on.
I wrote the code, but I don't have an understanding of how I can create a collection of matches for each abbreviation (there are only five of them). Next, need write collection of rows to different files.
Sub testProjectMl()
Sheets(ActiveSheet.Name).Range("K:K,M:M,N:N").EntireColumn.Delete 'Delete Columns
Set regexPatternOne = New RegExp
Dim theMatches As Object
Dim Match As Object
regexPatternOne.Pattern = "KP\d+|KS\d+|VT\d+|PP\d+|AK\d+" 'Pattern for Search Companies Matches in Range
regexPatternOne.Global = True
regexPatternOne.IgnoreCase = True
Dim CopyRng As Range 'Declarate New Range
With Sheets(ActiveSheet.Name)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'because I do not know how many lines there will be in the file
For i = 8 To LastRow
'some code
Next i
End With
End Sub
As a result, I need to create five different files with tables
KP_table -> Paste row with KP00000221
AK_table -> AK data and etc.
The task is complicated by the fact that there can be a lot of such data with abbreviations in the table, and all the row data needs to be filtered and entered into a separate file, where there will be information only on the company. That is, all these abbreviations: KP, KS, AK are different companies.
The problem is that I don't understand how to logically implement the idea: I created a regex pattern, now I need to create a collection (for example, KP_data) and add all the matches for KPXXXXXXXX and so on there.
Any suggestions? Thanks.

Answer 1

Please, test the next code. It uses a dictionary to keep a Union range of each case and drop each its item in the next sheet, with an empty row between them. Copying a Union range instead of each involved row, is much faster:
Sub testProjectMl()
Dim sh As Worksheet, shDest As Worksheet, lastRow As Long, firstRow As Long, lastERowDest As Long
Dim i As Long, arrA, dict As Object
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
firstRow = 7 'the row where the headers exist
Set shDest = sh.Next
arrA = sh.Range("A" & firstRow & ":A" & lastRow).value 'place the range in an array for faster iteration
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrA) 'iterate between the array rows
If Not dict.Exists(arrA(i, 1)) Then 'if not a key exists:
'create it composed by the header and the current row
dict.Add arrA(i, 1), Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
Else
'make a Union between the existing item and the new row:
Set dict(arrA(i, 1)) = Union(dict(arrA(i, 1)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
End If
Next i
'drop the dictionary items content (in the next sheet) with an empty row between each group:
For i = 0 To dict.count - 1
lastERowDest = shDest.Range("A" & shDest.rows.count).End(xlUp).row + 1
If lastERowDest = 2 Then lastERowDest = 1
dict.items()(i).Copy shDest.Range("A" & lastERowDest + 1)
Next i
End Sub

Answer 2

Option Explicit
Sub test()
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim MyKey As Object
Dim i As Long
Dim LR As Long
Dim LR2 As Long
Dim WKdata As Worksheet
Set WKdata = ThisWorkbook.Worksheets("data") 'Worksheet with source data
With WKdata
LR = .Range("A" & .Rows.Count).End(xlUp).Row 'last row with data
End With
For i = 8 To LR Step 1 '8 is first row with data, headers are in row 7
If Dict.Exists(WKdata.Range("A" & i).Value) = False Then
'This number is first time found. Create file and add it
Workbooks.Add 'now this is the activeworkbook
Dict.Add WKdata.Range("A" & i).Value, ActiveWorkbook.ActiveSheet 'create a reference for this file
WKdata.Range("A7:K7").Copy Dict(WKdata.Range("A" & i).Value).Range("A1:K1") 'headers from row 7
WKdata.Range("A" & i & ":K" & i).Copy Dict(WKdata.Range("A" & i).Value).Range("A2:K2") 'row 2 is always first row of data
Else
'this number has been found before. Add data to existing file
With Dict(WKdata.Range("A" & i).Value)
LR2 = .Range("A" & .Rows.Count).End(xlUp).Row + 1 '1 row below last row with data
End With
WKdata.Range("A" & i & ":K" & i).Copy Dict(WKdata.Range("A" & i).Value).Range("A" & LR2 & ":K" & LR2)
End If
Next i
Set Dict = Nothing
Set WKdata = Nothing
End Sub
The code loops trough a dictionary with references to each new file created.
My source data is a worksheet named Data
After executing code, I get new files for each key (grouped rows by keys)
As you can see, I got 3 different unique keys and each one to their file with all its data.
You only need to adapt the code to save each file where you want, following your pattern. Probably you'll need to loop trough each key of the dictionary, check number value and then save the file properly
About dictionaries in VBA, please check this source:
Excel VBA Dictionary – A Complete
Guide