VBA Dictionary greater than 1 pull items

[Stephen_IV]

I am trying to learn dictionary. Somone gave me the code below. What I am trying to do is almost the same thing but instead of counting the item I would like to pull the items. Please see below. Thanks in advance!

ID Last Name First Name 1111 aaaa aa 1111 2 1111 bbbb dd 5555 2 2222 cccc cc 4444 dddd dd 5555 eeee ee 5555 ffff ff 8888 gggg gg 9999 hhhh hh

Sub CountGreaterThenTwo()
Dim xcell As Range
Dim i As Long
Dim r As Range
Dim dic As Object
Set r = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
   For Each xcell In r
        If xcell.Value <> "" Then
            If Not dic.Exists(xcell.Value) Then
                Set dic(xcell.Value) = CreateObject("Scripting.Dictionary")
            End If
                dic(xcell.Value)(xcell.Offset(0, 1).Value & "|" & xcell.Offset(0, 2).Value) = Empty
            End If
    Next xcell
i = 1
    For Each k In dic.Keys
        If dic(k).Count > 1 Then
            i = i + 1
            Cells(i, 10).Value = k
            Cells(i, 11).Value = dic(k).Count
        End If
    Next k
End Sub

to this:

ID Last Name First Name 1111 aaaa aa 1111 aaaa|aa bbbb|bb 1111 bbbb dd 5555 eeee|ee ffff|ff 2222 cccc cc 4444 dddd dd 5555 eeee ee 5555 ffff ff 8888 gggg gg 9999 hhhh hh

 

[DanteAmor]

Check if the following approach helps you.

Sub greater_than_1_pull_items()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, ky As Variant
  Dim i As Long, j As Long, n As Long, y As Long, m As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = 1
  a = Range("A2", Range("C" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) + 1)
 
  'store in array b
  For i = 1 To UBound(a, 1)
    If Not dic.Exists(a(i, 1)) Then
      y = y + 1
      j = 2
      n = 1
      b(y, 1) = a(i, 1)
    Else
      y = Split(dic(a(i, 1)), "|")(0)   'counter row in output array
      j = Split(dic(a(i, 1)), "|")(1)   'counter column in output array
      n = Split(dic(a(i, 1)), "|")(2)   'counter items
      j = j + 1
      n = n + 1
    End If
    b(y, j) = a(i, 2) & "|" & a(i, 3)
    dic(a(i, 1)) = y & "|" & j & "|" & n
  Next
 
  'store in array c
  ReDim c(1 To y, 1 To UBound(b, 2))
  m = 0
  For Each ky In dic.keys
    If Split(dic(ky), "|")(2) > 1 Then
      m = m + 1
      For j = 1 To Split(dic(ky), "|")(1)
        c(m, j) = b(Split(dic(ky), "|")(0), j)
      Next
    End If
  Next
 
  'output array c
  Range("J2").Resize(y, UBound(b, 2)).Value = c
End Sub

 

[Stephen_IV]

Yes that will do it!! Thank you DanteAmor I appreciate your help and guidance on this!

 

[Peter_SSs]

If you are interested in a different (shorter) approach you could also try this.

Sub greater_than_1_pull_items_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("C" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) & ";" & a(i, 2) & "|" & a(i, 3)
  Next i
  With Range("J2:K2").Resize(d.Count)
    .Value = Application.Transpose(Array(d.Keys, d.Items))
    .Columns(2).TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(1, 1))
    .Columns(2).TextToColumns DataType:=xlDelimited, Semicolon:=True, Space:=False, Other:=False
    On Error Resume Next
    Intersect(.Columns(3).SpecialCells(xlBlanks).EntireRow, .CurrentRegion).Delete Shift:=xlUp
    On Error GoTo 0
  End With
End Sub

 

[Stephen_IV]

Peter_SSs love it!! Thank you so much for your solution! I greatly appreciate it!

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.