Keep or store rows for each non-repeated name

[KingTamo]

Hello excel experts

In the first worksheet, there are values from range("A2:F" & lr) where lr is the last row based on column A. In column D, there are names (the names are repeated). I need to build a dictionary for the unique names (column D) which will be keyed. Each key should store a 2d array of the rows related to that key.

I found that code but I got errors on this line [ReDim Preserve rows(LBound(rows) To UBound(rows) + 1, 1 To 6)]

Sub BuildDictionary()

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim lr As Long
    lr = ws.Cells(ws.rows.Count, "A").End(xlUp).Row
    
    Dim data As Variant
    data = ws.Range("A2:F" & lr).Value
    
    Dim i As Long
    For i = 1 To UBound(data)
        Dim key As String
        key = data(i, 4)
        If Not dict.Exists(key) Then
            dict.Add key, Array()
        End If
        Dim rows As Variant
        rows = dict(key)
        ReDim Preserve rows(LBound(rows) To UBound(rows) + 1, 1 To 6)
        rows(UBound(rows), 1) = data(i, 1)
        rows(UBound(rows), 2) = data(i, 2)
        rows(UBound(rows), 3) = data(i, 3)
        rows(UBound(rows), 4) = data(i, 4)
        rows(UBound(rows), 5) = data(i, 5)
        rows(UBound(rows), 6) = data(i, 6)
        dict(key) = rows
    Next i

End Sub

[Sintek]

sample file and expected output?

[KingTamo]

No specific output. I just want to build a dictionary with the unique keys from column D. and later we can loop through the keys and retrieve the stored rows.

[Sintek]

From experience you should well know that previously, code has been supplied, and YOU are not able to adapt it to fit your actual file...
Hence, so as not to waste time, upload a sample file and explain what it is you are wanting to achieve...

[KingTamo]

The code is well but there is a problem with the ReDim Preserve statement. No specific output sir sintek. just wanted to store the related rows to each unique key.

[KingTamo]

Sample of information:

col a --- col b --- col c --- col d --- col e --- col f
**************************************
aa --- bb --- cc --- ITEM1 --- ee --- ff
aaa --- bbb --- ccc --- ITEM2 --- eee --- fff
a1 --- b1 --- c1 --- ITEM1 --- e1 --- f1

The desired output
***************
ITEM1
aa --- bb --- cc --- ITEM1 --- ee --- ff
a1 --- b1 --- c1 --- ITEM1 --- e1 --- f1

ITEM2
aaa --- bbb --- ccc --- ITEM2 --- eee --- fff

[jindon]

Sub test()
    Dim x, e, r As Range
    With [a1].CurrentRegion
        x = .Columns("d").Offset(1).Address
        x = .Parent.Evaluate("unique(filter(" & x & "," & x & "<>""""))")
        Set r = [h1]
        r.CurrentRegion.EntireColumn.ClearContents
        For Each e In x
            r.Value = e
            r(2).Formula2 = "=filter(" & .Address & "," & .Columns("d").Address & "=""" & e & """)"
            r.CurrentRegion.Value = r.CurrentRegion.Value
            Set r = Range("h" & Rows.Count).End(xlUp)(3)
        Next
    End With
End Sub

[KingTamo]

Thanks a lot sir jindon. Is it probable to modify the first code that uses a dictionary?

[jindon]

that code doesn't make sense to me

Sub test()
    Dim a, e, w, i As Long, ii As Long, n As Long
    a = [a1].CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 4)) Then
                ReDim w(1 To UBound(a, 2), 1 To 2)
                w(1, 1) = a(i, 4)
            Else
                w = .Item(a(i, 4))
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            .Item(a(i, 4)) = w
        Next
        n = 1
        For Each e In .keys
            Cells(n, "h").Resize(UBound(.Item(e), 2), UBound(a, 2)) = Application.Transpose(.Item(e))
            n = n + UBound(.Item(e), 2) + 2
        Next
    End With
End Sub

[KingTamo]

Amazing code sir Jindon.

[KingTamo]

I noticed each block of results consists of the name as a key and the related rows. That's great.
How can I add another row (the headers) to be the second component
I mean the key is the first element. The header row is the second element. The third element is the related rows.

[jindon]

            If Not .exists(a(i, 4)) Then
                ReDim w(1 To UBound(a, 2), 1 To 2)
                w(1, 1) = a(i, 4)
            Else

            If Not .exists(a(i, 4)) Then
                ReDim w(1 To UBound(a, 2), 1 To 3)
                w(1, 1) = a(i, 4)
                for ii = 1 to ubound(a,2)
                    w(ii,2)=a(1,ii)
                next
            Else

[KingTamo]

Excellent. Thank you so much.