我的任務是提取表格并將“編號”列中的縮寫與公司串列相匹配。例如：將編號列中寫有“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
結果，我需要用表創建五個不同的檔案
KP_table -> 用 KP00000221 粘貼行
AK_table -> AK 資料等。
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.
uj5u.com熱心網友回復：
請測驗下一個代碼。它使用字典來保存Union每個案例的范圍，并將其每個專案放在下一張表中，它們之間有一個空行。復制一個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
uj5u.com熱心網友回復：
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 字典 - 完整指南
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/454695.html
上一篇：在Access中參考新匯入的表