VBA筛选器和复制行使用列表
我有一些代码拼接在一起，将我需要的数据转换成特定的格式。
我想要做的是从4个不同的列中find唯一的variables，然后在单独的列中返回这些variables的结果。 （我已经完成了）
然后我需要独立地过滤所有这些variables，并分别返回结果。 完成后，我需要将variables列表变成一个单元格，用逗号分隔，并放在所使用的filter的相邻行中。
Sku | CatID |CatID2 | ------ | ------|------ | 1234 | 1 |34 | 4567 | 2 |34 | 7890 | 3 |34 | 9898 | 2 |34 | 5643 | 1 |35 | 结果所需
CatID |Sku | ------|--------------------| 1 |1234,5643 | 2 |4567,9898 | 3 |7890 | 34 |1234,4567,7890,9898 | 35 |5643 |
代码我有:(没有接近完成的地方）
问题是，我正在以正确的方式进行？ 我怎样才能把这一切联系在一起？ 我的思考过程是按每个独特的CatID进行过滤，将结果复制并粘贴到相邻的行中，然后使用concat函数将其置于适当的格式中。
Sub GetUniques() Dim Na As Long, Nc As Long, Ne As Long Dim i As Long SkuCount = Cells(Rows.Count, "A").End(xlUp).Row Cat1 = Cells(Rows.Count, "U").End(xlUp).Row Ne = 2 For i = 2 To SkuCount Cells(Ne, "Y").Value = Cells(i, "P").Value Ne = Ne + 1 Next i For i = 2 To SkuCount Cells(Ne, "Y").Value = Cells(i, "Q").Value Ne = Ne + 1 Next i For i = 2 To SkuCount Cells(Ne, "Y").Value = Cells(i, "R").Value Ne = Ne + 1 Next i For i = 2 To SkuCount Cells(Ne, "Y").Value = Cells(i, "U").Value Ne = Ne + 1 Next i Range("Y:Y").RemoveDuplicates Columns:=1, Header:=xlNo NextFree = Range("Y2:Y" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row Range("Y" & NextFree).Select ActiveCell.Offset(0, 1).Select End Sub Function concat(useThis As Range, Optional delim As String) As String ' this function will concatenate a range of cells and return one string ' useful when you have a rather large range of cells that you need to add up Dim retVal, dlm As String retVal = "" If delim = Null Then dlm = "" Else dlm = delim End If For Each cell In useThis If CStr(cell.Value) <> "" And CStr(cell.Value) <> " " Then retVal = retVal & CStr(cell.Value) & dlm End If Next If dlm <> "" Then retVal = Left(retVal, Len(retVal) - Len(dlm)) End If concat = retVal End Function
我知道我迟到了，但这里又有一个解决scheme，具有以下好处：
- 这是一个更紧凑（希望可读）
- 只使用内置的
Collection - 通过使用
Join避免大string连接（即，对于大数据集，它可以更快地工作）。 - 不使用
Collection中的Remove操作，当从顶部删除项目时，这可能在计算上是昂贵的。
Sub filterAndCopy() Dim row As Range Dim inp As Range ' top left cell of input table Dim out As Range ' top left cell of output table Set inp = Worksheets("Sheet1").[a1] Set out = Worksheets("Sheet1").[e1] Dim cat As String Dim sku As String Dim c As New Collection Dim v As Variant Dim i As Long Dim a() As String ' collect data by category With inp.CurrentRegion For Each row In .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows sku = CStr(row.Cells(1)) For Each v In Array(row.Cells(2), row.Cells(3)) cat = CStr(v) ' CatID or CatID2 If Len(Trim(cat)) > 0 And Len(Trim(sku)) > 0 Then If Not contains(c, cat) Then c.Add New Collection, cat ' first item is CatID - empty key to avoid collisions with sku c(cat).Add cat, "" End If addIgnoreDups c(cat), sku, sku End If Next v Next row End With ' print result out(1, 1) = "CatID" out(1, 2) = "Sku" Set out = out(2, 1) ' next output row For Each v In c ReDim a(2 To v.Count) out(1, 1) = v(1) For i = LBound(a) To UBound(a): a(i) = v(i): Next i out(1, 2).Value2 = "'" & Join(a, ",") ' faster string concat Set out = out(2, 1) ' next output row Next v End Sub Sub addIgnoreDups(col As Collection, val As Variant, key As String) On Error Resume Next col.Add val, key End Sub Function contains(col As Collection, key As String) As Boolean On Error Resume Next col.Item key contains = (Err.Number = 0) On Error GoTo 0 End Function
结果是：
那么，我开始尝试用集合来简化这个问题，但是人VBA使用集合很烦人。 我会使用像Hambone字典，但我不想要求任何外部引用。
您可以通过更改For Each c in Range("B2:B"...的B来调整要search的列For Each c in Range("B2:B"...
只要确保您在GetKey c, [Offset], Vals, Keys更改偏移量
（这是多less列左/右你正在寻找的数据是。）
这是一个使用集合的解决scheme：
Sub GetUniques() Dim c As Range Dim Vals As New Collection Dim Keys As New Collection For Each c In Range("B2:B" & Cells(Rows.CountLarge, "B").End(xlUp).Row) GetKey c, -1, Vals, Keys Next c For Each c In Range("C2:C" & Cells(Rows.CountLarge, "C").End(xlUp).Row) GetKey c, -2, Vals, Keys Next c 'Where to put these values Dim outRow outRow = 2 'Start on Row 2 using columns... Dim z For Each z In Vals Cells(outRow, "G").NumberFormat = "@" Cells(outRow, "F").NumberFormat = "General" Cells(outRow, "G").Value = z 'G Cells(outRow, "F").Value = Keys(z) 'and F outRow = outRow + 1 Next z Range("F2:G" & outRow).Sort key1:=Range("F2"), DataOption1:=xlSortTextAsNumbers End Sub Sub GetKey(ByRef c As Range, Offset As Integer, ByRef Vals As Collection, ByRef Keys As Collection) If HasKey(Vals, c.Value) Then Dim d, NotUnique As Boolean NotUnique = False For Each d In Split(Vals(CStr(c.Value)), ",") If d = CStr(c.Offset(0, Offset).Value) Then NotUnique = True Exit For End If Next d If NotUnique = False Then Dim concat concat = Vals(CStr(c.Value)) Vals.Remove (CStr(c.Value)) Keys.Remove (CStr(concat)) Vals.Add concat & "," & c.Offset(0, Offset), CStr(c.Value) Keys.Add c.Value, concat & "," & c.Offset(0, Offset) End If Else Vals.Add CStr(c.Offset(0, Offset).Value), CStr(c.Value) Keys.Add CStr(c.Value), CStr(c.Offset(0, Offset).Value) End If End Sub Function HasKey(coll As Collection, strKey As String) As Boolean Dim var As Variant On Error Resume Next var = coll(strKey) HasKey = (Err.Number = 0) Err.Clear End Function
结果：
代码与评论和解释：
Sub GetUniques() 'c will iterate through each cell in the various ranges Dim c As Range 'Vals will store the values associated with each key (Key: 34 Val: 1234) Dim Vals As New Collection 'Keys will store the keys associated with each value (Key: 1234 Val: 34) Dim Keys As New Collection 'Loop through our first range (CatID) For Each c In Range("B2:B" & Cells(Rows.CountLarge, "B").End(xlUp).Row) 'Pass our range, offset, and collections to GetKey 'This just prevents having to copy/paste code twice with slight differences (The Offset) GetKey c, -1, Vals, Keys Next c For Each c In Range("C2:C" & Cells(Rows.CountLarge, "C").End(xlUp).Row) GetKey c, -2, Vals, Keys Next c 'Where to put these values Dim outRow outRow = 2 'Start on Row 2 using columns... Dim z For Each z In Vals Cells(outRow, "G").NumberFormat = "@" Cells(outRow, "F").NumberFormat = "General" Cells(outRow, "G").Value = z 'G Cells(outRow, "F").Value = Keys(z) 'and F outRow = outRow + 1 Next z Range("F2:G" & outRow).Sort key1:=Range("F2"), DataOption1:=xlSortTextAsNumbers End Sub Sub GetKey(ByRef c As Range, Offset As Integer, ByRef Vals As Collection, ByRef Keys As Collection) 'Does our Vals contain the current key (Example: 34)? If HasKey(Vals, c.Value) Then 'If so, let's find out if this is a unique value Dim d, NotUnique As Boolean NotUnique = False 'Split our stored values by our comma and check each one For Each d In Split(Vals(CStr(c.Value)), ",") 'If we find the same value, we don't need to store it If d = CStr(c.Offset(0, Offset).Value) Then NotUnique = True Exit For End If Next d 'If this is a unique value, let's add it to our stored string If NotUnique = False Then Dim concat 'Store the current value concat = Vals(CStr(c.Value)) 'Then, remove both the key/value from our collections Vals.Remove (CStr(c.Value)) Keys.Remove (CStr(concat)) 'Now, add it back in with the new value (Example: 1234 becomes 1234,4567) Vals.Add concat & "," & c.Offset(0, Offset), CStr(c.Value) Keys.Add c.Value, concat & "," & c.Offset(0, Offset) End If Else 'If we don't already have this key in our collection, just store it 'No reason to check if it is unique - it is clearly unique Vals.Add CStr(c.Offset(0, Offset).Value), CStr(c.Value) Keys.Add CStr(c.Value), CStr(c.Offset(0, Offset).Value) End If End Sub Function HasKey(coll As Collection, strKey As String) As Boolean Dim var As Variant On Error Resume Next var = coll(strKey) HasKey = (Err.Number = 0) Err.Clear End Function
作为一种select，你可能想考虑一个字典结构。 这些都很好，因为testing/parsing重复项更容易（也更高效），因为一切都被存储为关键值对。
以下是数据的一个简单例子。 在这种情况下，我把原始字典的价值dict另一个字典。 可能有一个更简单的方法来实例化新的字典，但我不知道。 在Perl中，大约20行代码将被$dict{$val1}{$val2} = 1replace，但显然不是Perl。
Sub GetUniques() Dim SkuCount, rw As Long Dim dict, d2 As Dictionary Dim ws As Worksheet Dim key, key1, key2, val As Variant Set ws = Sheets("Sheet1") Set dict = New Dictionary SkuCount = ws.Cells(Rows.Count, "A").End(xlUp).Row For rw = 2 To SkuCount key1 = ws.Cells(rw, 2).Value2 key2 = ws.Cells(rw, 3).Value2 val = ws.Cells(rw, 1).Value2 If dict.Exists(key1) Then Set d2 = dict(key1) d2(val) = 1 Else Set d2 = New Dictionary d2.Add val, 1 dict.Add key1, d2 End If If dict.Exists(key2) Then Set d2 = dict(key2) d2(val) = 1 Else Set d2 = New Dictionary d2.Add val, 1 dict.Add key2, d2 End If Next rw Set ws = Sheets("Sheet2") rw = 2 For Each key In dict.Keys Set d2 = dict(key) val = d2.Keys() ws.Cells(rw, 1).Value2 = key ws.Cells(rw, 2).NumberFormat = "@" ws.Cells(rw, 2).Value2 = Join(val, ",") rw = rw + 1 Next key End Sub
另外，你可以看到我从Sheet1的input，并把输出在Sheet2上。 这可能不是你想到的，但很容易改变。
噢，你应该在VBA中添加一个引用到Microsoft Scripting Runtime库来访问Dictionary类。
– 编辑 –
在这部分代码中解决了一个粗心的错误：
If dict.Exists(key2) Then Set d2 = dict(key1) ' <- this should be "key2" not "key1" d2(val) = 1 Else Set d2 = New Dictionary d2.Add val, 1 dict.Add key2, d2 End If
– 编辑＃2，Hambone的独白 –
我想要的是二维字典，我所关心的只是钥匙，而不是价值。 我为这个值使用了一个常数值1。
在你的例子中：
Sku | CatID |CatID2 | ------ | ------|------ | 1234 | 1 |34 | 4567 | 2 |34 | 7890 | 3 |34 | 9898 | 2 |34 | 5643 | 1 |35 |
如果一个二维字典可以很容易地声明，我想这样做：
dictionary [ 1, 1234] = 1 (again the value doesn't matter) dictionary [34, 1234] = 1 dictionary [ 2, 4567] = 1 dictionary [34, 4567] = 1 dictionary [ 3, 7890] = 1 dictionary [34, 7890] = 1
…等等。
所以最后，“34”的字典值将是另一个字典，其键为1234,4567,7890和9898。
您在评论中引用的这部分代码：
key1 = ws.Cells(rw, 2).Value2 key2 = ws.Cells(rw, 3).Value2 val = ws.Cells(rw, 1).Value2
只是分配了我上面使用的那些值
Cells(rw,2) (Col B) Cells(rw, 1) (Col A) VV dictionary [ 1, 1234] = 1 dictionary [34, 1234] = 1 ^ Cells(rw, 3) (Col C)
而VBA方法将这些字典翻译成字典是随之而来的。
重读这个，听起来像是一堆乱码，但我希望这对解释有帮助。