Question

我有一些代码可以拼接在一起，将我需要的数据转换为特定的格式。

我要做的是从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

Answer 1

作为替代方案，您可能需要考虑字典结构。这些很好，因为测试/解决重复项更容易（也更有效），因为所有内容都存储为键值对。

以下是您的数据可能会出现的快速示例。在这种情况下，我将原始字典dict的值设为另一个字典。可能有一种更简单的方法来实时实例化新词典，但我不知道。在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

此外，您可以看到我从Sheet1获取输入并将输出放在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的Soliloquy -

我想要的是一个二维字典，而我所关心的只是关键，而不是价值观。我为值使用了常数值1。

在你的例子中：

Sku    | CatID |CatID2 |
------ | ------|------ |
1234   | 1     |34     |
4567   | 2     |34     |
7890   | 3     |34     |
9898   | 2     |34     |
5643   | 1     |35     |

如果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; 34＆＃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用于字典词典的方法。

重读这个，听起来像是一堆胡言乱语，但我希望在解释中有所帮助。

Answer 2

好吧，我开始尝试用集合来简化这个，但是男人VBA使用集合很烦人。我会使用像Hambone这样的字典，但我不想要任何外部引用。

您可以通过更改For Each c in Range("B2:B"...

中的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

Answer 3

我知道我迟到了，但这是对解决方案的另一种看法，具有以下好处：

它更紧凑（希望可读）
仅使用内置Collection
使用Join避免大字符串连接（即，对于大型数据集，它可以更快地工作）。
从Remove使用Collection操作时，从顶部删除项目可能会耗费大量资金。

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筛选和复制行

3 个答案: