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.

CodePudding user response：

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

CodePudding user response：

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