Gather unique values in one row for each uniqe key

[YasserKhalil]

Hello everyone
I have 6 columns: The first four columns are repeated values and column E should be for the header row and column F should be the values
The headers are

Code: Select all

Suppose the rows for one item looks like that
---------------------------------------------------------
AA - 10/02/1998 - 10/03/1998 - 100 - S1 - Yes
AA - 10/02/1998 - 10/03/1998 - 100 - S2 - No
AA - 10/02/1998 - 10/03/1998 - 100 - S3 - Maybe
AA - 10/02/1998 - 10/03/1998 - 100 - S4 - NA
AA - 10/02/1998 - 10/03/1998 - 100 - S5- Real

The expected output 
-------------------------
Code - Date1 - Date2 - Form Score - S1 - S2 - S3 - S4 - S5
AA - 10/02/1998 - 10/03/1998 - 100 - Yes - No - Maybe - NA- Real

I already have a code but couldn't modify it
[code]Sub Test()
    Dim arr, v1, v2, coll As New Collection, s As String, max As Long, i As Long, j As Long
    Application.ScreenUpdating = False
        arr = Sheets(1).Range("A1").CurrentRegion.Value
        For i = 1 To UBound(arr, 1)
            s = CStr(arr(i, 1))
            On Error Resume Next
                coll.Add Key:=s, Item:=New Collection
            On Error GoTo 0
            If coll(s).Count = 0 Then coll(s).Add s
            coll(s).Add CStr(arr(i, 6))
        Next i
        For Each v1 In coll
            If v1.Count > max Then max = v1.Count
        Next v1
        ReDim arr(1 To coll.Count, 1 To max)
        i = 0
        For Each v1 In coll
            i = i + 1
            j = 0
            For Each v2 In v1
                j = j + 1
                arr(i, j) = v2
            Next v2
        Next v1
        For j = 2 To max
            arr(1, j) = j - 1
        Next j
        With Sheets(3).Range("A1")
            .CurrentRegion.Clear
            .Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            With .CurrentRegion
                .EntireColumn.AutoFit
                .Borders.Value = 1
            End With
        End With
    Application.ScreenUpdating = True
End Sub

The code is working well, but I couldn't get columns B to columns D. Another point, the headers are numerical 1 - 2 - 3 and so on but I need to get the headers of the unique values of column E [S1- S2- S3..] and so on.

[HansV]

I don't know if I can help, but you'll need to attach a small but representative sample workbook again.

[YasserKhalil]

Here's a sample file

[HansV]

Try this:

Code: Select all

Sub Transform()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim ars As Variant
    Dim m As Long
    Dim s As Long
    Dim t As Long
    Dim c As Long
    Dim dcc As Object
    Dim dcq As Object
    Dim kyc As Variant
    Dim kyq As Variant
    Set wss = Worksheets(1)
    ars = wss.Range("A1").CurrentRegion.Value
    m = UBound(ars)
    Set dcc = CreateObject(Class:="Scripting.Dictionary")
    Set dcq = CreateObject(Class:="Scripting.Dictionary")
    For s = 2 To m
        dcc(ars(s, 1)) = Null
        dcq(ars(s, 5)) = Null
    Next s
    ReDim art(1 To UBound(dcc.Keys) + 2, 1 To UBound(dcq.Keys) + 5)
    Set wst = Worksheets(3)
    t = 1
    For c = 1 To 4
        art(t, c) = ars(t, c)
    Next c
    For Each kyq In dcq.Keys
        art(t, c) = kyq
        c = c + 1
    Next kyq
    For s = 2 To m
        If ars(s, 1) <> ars(s - 1, 1) Then
            t = t + 1
            For c = 1 To 4
                art(t, c) = ars(s, c)
            Next c
        End If
        c = Application.Match(ars(s, 5), dcq.Keys, 0) + 4
        art(t, c) = ars(s, 6)
    Next s
    wst.Cells.Clear
    wst.Range("A1").Resize(UBound(dcc.Keys) + 2, UBound(dcq.Keys) + 5).Value = art
End Sub

[p45cal]

Maybe you don't need a macro.
In the attached, your data as a table called Table1
At cell H1 a power query table which if you change the data in Table1 will need to be refreshed by right-clicking the result table and choosing Refresh.

Completely independently there's a pivot at cell AC1. Would need refreshing too on change of source data.

[YasserKhalil]

Amazing. Thank you very much everyone.

[DocAElstein]

Hello
Here is another VBA way, just for comparison. It’s not using the dictionary type way, which seems often to be the usually and best way for these sort of things.

This following way is a bit unusual but might not be too bad in comparison, since it mostly does one loop through all the data rows. That is done by two Do While Loop things, one nested in the other. But the way it is written means it is effectively just looping once through all the data rows

The main thing that is done in the looping is building up a single string of most of the wanted output. It produces it in a form that the (Windows) Clipboard seems to end up giving to Excel when Excel does a worksheet .Paste
So the macro puts it in the (Windows) Clipboard ( or does something that to a first Layman approximation could be considered to be doing that. ( Only SpeakEasy and a few others seem to know for sure I expect! :) ) ).
Most of the output is then .Pasted out


Here is a more fuller code to look at, to figure out what’s going on a bit easier
https://excelfox.com/forum/showthread.p ... #post19820
https://excelfox.com/forum/showthread.p ... #post19821



Here is a shortened version

Code: Select all

 Sub SnibIt() '  https://eileenslounge.com/viewtopic.php?p=304939#p304939
Dim Wss As Worksheet, Wst As Worksheet
 Set Wss = ThisWorkbook.Worksheets.Item(1): Set Wst = ThisWorkbook.Worksheets.Item(3)
Dim CuRe As Range
 Set CuRe = Wss.Range("A1").CurrentRegion.Resize(Wss.Range("A1").CurrentRegion.Rows.Count + 1)            ' An extra empty row is often useful to make a  Do While Loop thing  of this sort teminate and not error when looking at the next after last
Dim Ars() As Variant
 Let Ars() = CuRe.Value
Dim RCnt As Long: Let RCnt = 2
Dim strClp As String: Let strClp = "ReptClms"                                                             ' The final string of data output to go in the clipboard to be pasted out.  I add a place with  ReptClms  whgich i replace later with the repeated columns
    Do While RCnt < UBound(Ars(), 1)                                   ' Outer Loop - Loops once for each section
        Do                             ' Inner Loop - loops in each section for as many rows in each section
         Let strClp = strClp & vbTab & Ars(RCnt, 6)                                     ' This is buildiung the   Yes NA Maybe Real   string bit for each section
         Let RCnt = RCnt + 1                                            ' Move a row down in each section or to next section
        Loop While Ars(RCnt - 1, 1) = Ars(RCnt, 1)
      Let strClp = Replace(strClp, "ReptClms" & vbTab, Ars(RCnt - 1, 1) & vbTab & Ars(RCnt - 1, 2) & vbTab & Ars(RCnt - 1, 3) & vbTab & Ars(RCnt - 1, 4) & vbTab, 1, 1, vbBinaryCompare) & vbCr & vbLf & "ReptClms"
    Loop ' While RCnt < UBound(Ars(), 1)
 Let strClp = Left(strClp, Len(strClp) - 10)                                                                  ' This takes off the 11 characters of    vbCr vbLf R e p t C l m s
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '    http://web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
 objDataObject.SetText Text:=strClp
 objDataObject.PutInClipboard
 Wst.Paste Destination:=Wst.Range("A2")
 Let Wst.Range("A1:D1").Value = Wss.Range("A1:D1").Value
 Let Wst.Range("E1").Resize(1, 14).Value = Evaluate("=""S""" & "&" & "COLUMN(A:" & Split(Cells(1, Wst.Range("A1").CurrentRegion.Columns.Count - 4).Address, "$")(1) & ")")
End Sub 

Both versions along with Han’s is in the uploaded file. Initial results suggest all macros give the same results using the supplied test data.

Alan

[YasserKhalil]

Thank you very much, Mr. Alan