Try this:-

Code:

Sub MG18Jul51
Dim Ray As Variant, n As Long, Q As Variant, Ac As Long, Dic As Object
Ray = Cells(5, 3).CurrentRegion
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For n = 2 To UBound(Ray, 1)
If Not Dic.exists(Ray(n, 1)) Then
ReDim nray(1 To 7, 1 To 1)
For Ac = 2 To UBound(Ray, 2)
nray(Ac - 1, 1) = Ray(n, Ac)
Next Ac
Dic.Add Ray(n, 1), nray
Else
Q = Dic(Ray(n, 1))
ReDim Preserve Q(1 To 7, 1 To UBound(Q, 2) + 1)
For Ac = 2 To UBound(Ray, 2)
Q(Ac - 1, UBound(Q, 2)) = Ray(n, Ac)
Next Ac
Dic(Ray(n, 1)) = Q
End If
Next n
Dim K As Variant
Dim Rng As Range, Dn As Range, c As Long, col As Long
c = 6: col = 38
Set Rng = Range("D1:J3")
For Each Dn In Rng
If Dic.exists(Dn.Value) Then
col = IIf(col = 6, 38, 6)
Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)) = Dn.Value
Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)).Interior.ColorIndex = col
Cells(c, "N").Resize(UBound(Dic(Dn.Value), 2), 7) = Application.Transpose(Dic(Dn.Value))
c = c + UBound(Dic(Dn.Value), 2)
End If
Next Dn
End Sub

Regards Mick

## Like this thread? Share it with others