Multiple and variant item of dictionary

I Want to save item multiple item in one key
1. as value
2. as range (union range)
3.as number
IS Posible to save multiple variant typename of item from each key

 Sub bb()
 Dim d As Object, i&, ii&, j&, sn, k, Q
 sn = [a1:b6].Value
 Set d = CreateObject("scripting.dictionary")
 For i = 1 To UBound(sn)
   k = sn(i, 1) & sn(i, 2)
     If Not d.exists(k) Then
 
          d.Add k, Array(sn(i, 1), Cells(i, 1), 1)
     Else
          Q = d(k)
          Q(0) = Q(0) & "," & sn(i, 1)
          Q(1) = Union(Q(1), Cells(i, 1))
          Q(2) = Q(2) + 1
          d(k) = Q
     End If
 Next i
For Each ky In d
    If d(ky)(2) = 1 Then
      d.Remove ky
    End If
Next ky

For Each e In d.keys
    MsgBox d(e)(0)   ' this OK
    MsgBox d(e)(1)   ' THIS IS ERROR PLEASE HELP ME
Next e
End Sub

d(e)(1) is a range of cells and the MsgBox is expecting text.

This might work to display the cells address
MsgBox d(e)(1).Address

Or the value of the first cell
MsgBox d(e)(1)(1).Value

still not run AlphaFrog
Q = d(k)
Q(0) = Q(0) & "," & sn(i, 1)
Q(1) = Union(Q(1), Cells(i, 1)) 'this need to set but i can not write coding 'OBJECT REQUAIRED
Q(2) = Q(2) + 1
d(k) = Q

still not understand

Sub bb()
Dim d As Object, i&, ii&, j&, sn, k, Q
sn = [a1:b6].Value
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(sn)
k = sn(i, 1) & sn(i, 2)
If Not d.exists(k) Then

d.Add k, Array(sn(i, 1), Cells(i, 1), 1)
Else
Q = d(k)
Q(0) = Q(0) & "," & sn(i, 1)
Q(1) = Union(Q(1), Cells(i, 1))
Q(2) = Q(2) + 1
d(k) = Q
End If
Next i
For Each ky In d
If d(ky)(2) = 1 Then
d.Remove ky
End If
Next ky

For Each e In d.keys
MsgBox d(e)(0) ' this OK
MsgBox d(e)(1) ' how to d(e)(1) not error i has change to MsgBox d(e)(1)(1).Value but still error
Next e
End Sub

What is it you actually want to store in the dictionary?

What's in the range A1:B6?

norri i hope you understand what i want from my coding to save any variant item FOR each key
1.Save range.address 'for interior colorindex
2.save range.row 'for copy data if meet criteria from third item
3.number 'only duplikat to executed IF NUMBER > 1

 Sub bb()
 Dim d As Object, i&, rw&, j&, a&, c&, sn, Q, y(), it, s$, SP, cr&, kl&
 kl = 1
 With Sheet1.[a1].CurrentRegion
     sn = .Value
   Dim k(1 To 3)
    
     
     Set d = CreateObject("scripting.dictionary")
  For cr = 1 To 3
   ReDim y(1 To UBound(sn, 1), 1 To UBound(sn, 2) * cr)
     For i = 1 To UBound(sn)
      k(1) = sn(i, 1) & sn(i, 2)
      k(2) = sn(i, 1) & sn(i, 3)
      k(3) = sn(i, 2) & sn(i, 3)
       
                       If Not d.Exists(k(cr)) Then
                            d.Add k(cr), Array(.Cells(i, 1).Address, Cells(i, 1).Row, 1)
                       Else
                            Q = d(k(cr))
                            Q(0) = Q(0) & "," & .Cells(i, 1).Address
                            Q(1) = Q(1) & "," & Cells(i, 1).Row
                            Q(2) = Q(2) + 1
                            d(k(cr)) = Q
                       End If
      Next i
        For Each ky In d: If d(ky)(2) = 1 Then d.Remove ky
        Next ky
                 For Each it In d.keys
                      SP = ""
                      SP = Split(d(it)(1), ",")               'FIRST TAKE ROW FROM ITEMS(1)
                      For c = 0 To UBound(SP)
                            If Len(c) Then rw = rw + 1
                              For j = 1 To 3
                                   y(rw, j) = .Cells(SP(c), j)
                              Next j
                      Next c                                   'SECOND TO PUT COLOUR TO DATA  [A1:C7]
                 Next it
    .Cells(16, kl).Resize(UBound(y, 1), UBound(y, 2) * 3) = y
     kl = kl + UBound(sn, 2) * cr
     rw = 0: c = 0: j = 1  
     d.RemoveAll
   Next cr
    
 End With
End Sub

NORI.png

Any chance you could upload a sample workbook?

Click on GO ADVANCED, scroll down and click Manage Attachments.

Originally Posted by Norie

Any chance you could upload a sample workbook?

Click on GO ADVANCED, scroll down and click Manage Attachments.

I am sorri nori
My oponion single dictionary can not
Save multiple typename of item
My code has sucsess using (range.address)

Sub REW2()
 Dim d As Object, i&, rw&, j&, a&, c&, sn, Q, y(), it, s$, SP, cr&, kl&
 kl = 1
 With Sheet1.[A1].CurrentRegion
      sn = .Value
 Dim k(1 To 3)

  Set d = CreateObject("scripting.dictionary")
  For cr = 1 To UBound(k)
   ReDim y(1 To UBound(sn, 1), 1 To UBound(sn, 2) * cr)
     For i = 1 To UBound(sn)
      k(1) = sn(i, 1) & sn(i, 2)
      k(2) = sn(i, 1) & sn(i, 3)
      k(3) = sn(i, 2) & sn(i, 3)
            If Not .Cells(i, 10) = "A" Then
                       If Not d.Exists(k(cr)) Then
                            d.Add k(cr), Array(.Cells(i, 1).Address, Cells(i, 1).Row, 1)
                       Else
                            Q = d(k(cr))
                            Q(0) = Q(0) & "," & .Cells(i, 1).Address
                            Q(1) = Q(1) & "," & Cells(i, 1).Row
                            Q(2) = Q(2) + 1
                            d(k(cr)) = Q
                       End If
             End If
      Next i
        For Each ky In d: If d(ky)(2) = 1 Then d.Remove ky
        Next ky
                 For Each it In d.keys
                  SA = d(it)(0)
                  .Range(SA).Offset(, 9) = "A"
                      SP = ""
                      SP = Split(d(it)(1), ",")               'INPUT ROW
                      For c = 0 To UBound(SP)
                            If Len(c) Then rw = rw + 1
                              For j = 1 To UBound(sn, 2)
                                   y(rw, j) = .Cells(SP(c), j)
                              Next j
                      Next c
                 Next it
   
    .Cells(16, kl).Resize(UBound(y, 1), UBound(y, 2)) = y
    
     kl = kl + (UBound(sn, 2))
     rw = 0: c = 0: j = 1
     d.RemoveAll
   Next cr
    .Columns(10).ClearContents
 End With
End Sub

You should be using Set with objects:

          Set Q(1) = Union(Q(1), Cells(i, 1))

Originally Posted by rorya

You should be using Set with objects:

          Set Q(1) = Union(Q(1), Cells(i, 1))

Ok thankyou