将模式数据添加到集合并将集合中的行复制到不同的文件

Question

我的任务是提取 table 并将“数字”列中的缩写与公司列表匹配。例如：将Number列中所有写有“KP00000221”的行复制到一个单独的文件中。对于“VT”、“AK”等也应该这样做。

我写了代码，但我不明白如何为每个缩写创建一个匹配集合（只有五个）。接下来，需要将行集合写入不同的文件。

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

因此，我需要用 tables

创建五个不同的文件

KP_table -> 使用 KP00000221

粘贴行

AK_table -> AK数据等

由于table中可以有很多这样的带有缩写的数据，所以任务很复杂，并且需要将所有行数据过滤并输入到一个单独的文件中，其中将仅提供有关公司的信息。也就是说，所有这些缩写：KP、KS、AK 是不同的公司。

问题是我不明白如何在逻辑上实现这个想法：我创建了一个正则表达式模式，现在我需要创建一个集合（例如，KP_data）并添加所有匹配项KPXXXXXXXX 等等。有什么建议么？谢谢。

Answer 1

请测试下一个代码。它使用字典来保留每个案例的 Union 范围，并将其每个项目放在下一个 sheet 中，它们之间有一个空行。复制 Union 范围而不是每个涉及的行，要快得多：

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

代码循环遍历字典，引用每个新创建的文件。

我的源数据是一个名为 Data

的工作表

执行代码后，我为每个键获取新文件（按键分组行）

如您所见，我有 3 个不同的唯一密钥，每个密钥都指向其文件及其所有数据。

您只需按照您的模式调整代码，将每个文件保存到您想要的位置。可能你需要遍历字典的每个键，检查数值然后正确保存文件

关于 VBA 中的词典，请查看此来源：

Excel VBA Dictionary – A Complete Guide

将模式数据添加到集合并将集合中的行复制到不同的文件

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

excel

vba