In sheet1, I have data in 6 columns like that

And this is my try with the code

    Sub Test()
    Dim a, dic As Object, i As Long, ii As Long
    With Sheet1
    a = .Range("A1").CurrentRegion.Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a, 1)
        If Not dic.Exists(a(i, 2)) Then
        dic(a(i, 2)) = Array(a(i, 3), a(i, 4), a(i, 5), a(i, 6))
        Else
        For ii = 0 To 3
            If dic(a(i, 2))(ii) = Empty Then
                dic(a(i, 2))(ii) = a(i, ii   3)
            End If
        Next ii
        End If
    Next i
    .Range("J1").Resize(dic.Count, 1).Value = Application.Transpose(dic.Keys)
    .Range("K1").Resize(dic.Count, 4).Value = dic.Items
End With
End Sub

I could get the keys with no problem but how to return the items. The items should be the names in C2:F11

For example:

Name1 Ahmed Khaled Empty Amany

Another Example:

Name2 Ahmed Khaled Reda Amany

The target in simple words to join the data for each unique name only if there is no data inside the array items.

** I think I can solve it with the help of comments and please tell me if there are any notes

Sub Test()
    Dim a, w, dic As Object, i As Long, ii As Long
    With Sheet1
    a = .Range("A1").CurrentRegion.Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a, 1)
        If Not dic.Exists(a(i, 2)) Then
        dic(a(i, 2)) = Array(a(i, 3), a(i, 4), a(i, 5), a(i, 6))
        Else
        w = dic(a(i, 2))
        For ii = 0 To 3
            If w(ii) = Empty Then
                w(ii) = a(i, ii   3)
            End If
        Next ii
        dic(a(i, 2)) = w
        End If
    Next i
    .Range("J1").Resize(dic.Count, 1).Value = Application.Transpose(dic.Keys)
    .Range("K1").Resize(dic.Count, 4).Value = Application.Transpose(Application.Transpose(dic.Items))
End With
End Sub

CodePudding user response：

Transpose Data

• This is using the items of the dictionary as columns in the 'Redim Preserve' Items Array.

Option Explicit

Sub Test()
    
    Dim ws As Worksheet: Set ws = Sheet1
    Dim srg As Range: Set srg = ws.Range("A1").CurrentRegion
    Dim sData As Variant: sData = srg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim iData() As Variant
    Dim Key As Variant
    Dim n As Long
    Dim sr As Long
    Dim ir As Long
    Dim ic As Long
    
    For sr = 1 To UBound(sData, 1)
        Key = sData(sr, 2)
        If Not dict.Exists(Key) Then
            n = n   1
            dict(Key) = n
            ReDim Preserve iData(1 To 4, 1 To n) ' add another column
            For ir = 1 To 4
                iData(ir, n) = sData(sr, ir   2)
            Next ir
        Else
            ic = dict(Key) ' write the column of the current Key to a variable
            For ir = 1 To 4
                If IsEmpty(iData(ir, ic)) Then
                    iData(ir, ic) = sData(sr, ir   2)
                End If
            Next ir
        End If
    Next sr
    
    ws.Range("J1").Resize(dict.Count).Value = Application.Transpose(dict.Keys)
    ws.Range("K1").Resize(n, 4).Value = Application.Transpose(iData)

End Sub

CodePudding user response：

You have to walk through each entry in the array in order to get those names back out to the worksheet. Here is an example:

Option Explicit

Sub Test()
    Dim a, dic As Object, i As Long, ii As Long
    With Sheet1
        a = .Range("A1").CurrentRegion.Value
        Set dic = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not dic.Exists(a(i, 2)) Then
            dic(a(i, 2)) = Array(a(i, 3), a(i, 4), a(i, 5), a(i, 6))
            Else
            For ii = 0 To 3
                If dic(a(i, 2))(ii) = Empty Then
                    dic(a(i, 2))(ii) = a(i, ii   3)
                End If
            Next ii
            End If
        Next i
        
        Dim dest As Range
        Set dest = .Range("J1")
        Dim entry As Variant
        For Each entry In dic.keys
            Dim names As Variant
            names = dic(entry)
            
            dest.Offset(0, 0).Value = entry
            For i = LBound(names) To UBound(names)
                dest.Offset(0, i   1).Value = names(i)
            Next i
            Set dest = dest.Offset(1, 0)
        Next entry
    End With
End Sub

CodePudding user response：

I think the dictionary assignment code, whatever that is, just doesn't support arrays I think.

Sub test()
    
    Dim vaValues As Variant
    Dim i As Long, j As Long
    Dim dc As Scripting.Dictionary
    Dim wf As WorksheetFunction
    Dim x As Variant
    
    vaValues = Sheet1.Cells(1, 1).CurrentRegion.Value
    Set dc = New Scripting.Dictionary
    Set wf = Application.WorksheetFunction
    
    For i = LBound(vaValues, 1)   1 To UBound(vaValues, 1)
        If Not dc.Exists(vaValues(i, 2)) Then
            dc.Add vaValues(i, 2), wf.Index(vaValues, i, Array(3, 4, 5, 6))
        Else
            For j = 1 To 4
                If Len(dc(vaValues(i, 2))(j)) = 0 Then
                    x = dc(vaValues(i, 2))
                    x(j) = vaValues(i, j   2)
                    dc(vaValues(i, 2)) = x
                End If
            Next j
        End If
    Next i
    
    For i = 0 To 6
        Debug.Print Join(dc.Items(i), " ")
    Next i
    
End Sub