VBA使用列表筛选和复制行

我有一些代码，我正在拼接在一起，将我需要的数据转换成特定的格式

我要做的是从4个不同的列中找到唯一的变量，然后在单独的列中返回这些变量的结果。（我已经做到了）

然后我需要独立地过滤所有这些变量，并分别返回结果。完成后，我需要将变量列表转换为单个单元格，用逗号分隔，并放入所用过滤器的相邻行

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

Sub-GetUniques（）
暗Na为长，Nc为长，Ne为长
我想我会坚持多久
SkuCount=单元格（Rows.Count，“A”）.End（xlUp）.Row
Cat1=单元格（行数，“U”）。结束（xlUp）。行
Ne=2
对于i=2，以进行计数
单元格（Ne，“Y”）。数值=单元格（i，“P”）。数值
Ne=Ne+1
接下来我
对于i=2，以进行计数
单元（Ne，“Y”）.值=单元（i，“Q”）.值
Ne=Ne+1
接下来我
对于i=2，以进行计数
单元格（Ne，“Y”）。数值=单元格（i，“R”）。数值
Ne=Ne+1
接下来我
对于i=2，以进行计数
单元格（Ne，“Y”）。数值=单元格（i，“U”）。数值
Ne=Ne+1
接下来我
范围（“Y:Y”）。移除的重复列：=1，标题：=xlNo
NextFree=Range（“Y2:Y”和Rows.Count）.Cells.SpecialCells（xlcelltypebanks）.Row
范围（“Y”和下一个自由）。选择
ActiveCell.Offset（0，1）。选择
端接头
函数concat（使用此作为范围，可选delim作为字符串）作为字符串
'此函数将连接一系列单元格并返回一个字符串
“当您有相当大范围的单元格需要添加时非常有用
Dim retVal，dlm作为字符串
retVal=“”
如果delim=Null，则
dlm=“”
其他的
dlm=delim
如果结束
对于使用中的每个单元格
如果CStr（cell.Value）”和CStr（cell.Value）”，则
retVal=retVal&CStr（cell.Value）&dlm
如果结束
下一个
如果是dlm“”，则
retVal=左（retVal，Len（retVal）-Len（dlm））
如果结束
concat=retVal
端函数
< /代码> 作为另一种选择，您可能需要考虑字典结构。这很好，因为测试/解析重复项更容易（也更高效），因为所有内容都存储为键值对

下面是一个快速的示例，说明您的数据可能是什么样的。在本例中，我将原始字典的值设置为另一本字典。可能有一种更简单的方法可以动态实例化新词典，但我不知道。在Perl中，其中大约20行代码将替换为
$dict{$val1}{$val2}=1
，但这显然不是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

此外，您可以看到我从表1获取输入，并将输出放在表2上。这可能不是你的想法，但很容易改变

哦，是的，您应该在VBA中添加对Microsoft脚本运行库的引用，以访问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

如果2d字典可以轻松地声明这一点，我希望这样做：

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)
                 V    V
    dictionary [ 1, 1234] = 1
    dictionary [34, 1234] = 1
                 ^
Cells(rw, 3) (Col C)

接下来就是VBA-ish将这些内容输入字典字典的方法

重读这篇文章，听起来像是胡言乱语，但我希望这能对解释有所帮助。
好吧，我开始尝试用集合来简化这一点，但man VBA使用集合很烦人。我本来会使用像《汉姆伯恩》这样的字典，但我不想要求任何外部参考

您可以通过更改范围内每个c的
中的B（“B2:B”…

只需确保在
GetKey c、[offset]、Vals、Keys中更改偏移量

（是指您要查找的数据的左/右列数。）

下面是一个使用集合的解决方案：

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

我知道我参加聚会迟到了，但下面是对该解决方案的另一种看法，它有以下好处：

它有点紧凑（希望可读）
仅使用内置的
集合
通过使用
Join
，避免大字符串连接（也就是说，它可以更快地处理大数据集）
不使用
Remove
操作从
Collection
中删除项，从顶部删除项时，这可能会导致计算开销
子过滤器副本（）
暗行作为范围
将inp作为输入表左上角的“范围”单元格
变暗为输出表左上角的“范围”单元格
Set inp=工作表（“表1”）[a1]
放样=工作表（“表1”）[e1]
暗猫如弦
作为字符串的暗淡sku
Dim c作为新系列
Dim v作为变体
我想我会坚持多久
将（）变暗为字符串
'按类别收集数据
使用inp.CurrentRegion
对于.Offset（1，0）中的每一行。调整大小（.Rows.Count-1、.Columns.Count）.Rows
sku=CStr（行单元格（1））
对于阵列中的每个v（行单元格（2），行单元格（3））
cat=CStr（v）'CatID或CatID2
如果Len（微调（cat））>0且Len（微调（sku））>0，则
如果不包含（c，cat），则
c、 添加新集合，cat
'第一项是CatID-空键，以避免与sku发生冲突
c（类别）。添加类别“”
如果结束
添加了c（类别）、sku、sku
终点
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