VBA Filter and Copy Rows using list

Question

I have some code that I am splicing together to convert data I need into a specific format.

What I am trying to do is find unique variables from 4 different columns, then return the result of those in a separate column. (Which I have done)

Then I need to filter by all of those variables independently and return the results separately. After this is complete I need to turn the list of variables into a single cell, seperated by comma's, and put in the adjacent row of the filter that was used.

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

Result Desired

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

Code I have: (No where near complete)

The question is, am I going about this the right way? How can I tie this all together? My thought processs was to filter by each of the unique CatIDs, copy and paste the results into adjacent rows, then use concat function to put it in the proper format.

    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

I know I am late to the party, but here is another take on the solution with the following benefits:

1. It is a bit more compact (and hopefully readable)
2. Only uses built-in Collection
3. Avoids large string concatenation by using Join (i.e. it will work faster with large datasets).
4. Doesn't use Remove operation from Collection which may be computationally expensive when removing items from the top.

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

And the result is:

Answer 2

As an alternative you might want to consider a dictionary structure. These are nice because testing / resolving duplicates is easier (and more efficient) since everything is stored as a key value pair.

Here is a quick example of what this might look like with your data. In this case, I made the value of the original dictionary dict another dictionary. There may be an easier way to instantiate new dictionaries on the fly, but I don't know it. In Perl, about 20 of those lines of code would be replaced with $dict{$val1}{$val2} = 1, but this obviously isn't 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

Also, you can see I took the inputs from Sheet1 and put the outputs on Sheet2. That may not be what you had in mind, but it's easy enough to change.

Oh yeah, and you should to add a reference in VBA to the Microsoft Scripting Runtime library to access the Dictionary class.

-- EDIT --

Resolved a careless error in this section of code:

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

-- EDIT #2, Hambone's Soliloquy --

What I wanted was a 2 dimensional dictionary, and all I cared about was the keys, not the values. I used a constant value of 1 for the values.

In your example:

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

If a 2d dictionary were possible to declare this easily, I would want to do this:

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

...And so on.

So in the end, the dictionary value for "34" would be another dictionary with keys of 1234, 4567, 7890 and 9898.

This section of code, which you referenced in your comment:

key1 = ws.Cells(rw, 2).Value2
key2 = ws.Cells(rw, 3).Value2
val = ws.Cells(rw, 1).Value2

Just assigns those values I was using above

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)

And the VBA-ish way to get those into a dictionary of dictionaries is what followed.

Re-reading this, it sounds like a bunch of gibberish, but I hope that's helpful in the explanation.

Answer 3

Well, I started out trying to simplify this with collections, but man VBA is annoying using collections. I would have used a dictionary like Hambone, but I didn't want to require any external references.

You can tweak the columns to search by changing the B in For Each c in Range("B2:B"...

Just make sure that you change the offset in GetKey c, [Offset], Vals, Keys

(It's how many columns to the left/right the data you are looking for is.)

Here is a solution using collections:

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

Results:

Code with comments and explanation:

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