Very unusual data transformation

User avatar
Abraxus
3StarLounger
Posts: 236
Joined: 01 Mar 2010, 17:34
Location: Blue Springs, MO

Very unusual data transformation

Post by Abraxus »

I have a coworker who needs to take some data and transform it in an unusual way.

He has a list with data in 4 columns where column A is very high-level and column D is more specific. (It's a business taxonomy but my example is food-related) For example, column A might say Bakery, Column B would contain Bread and Cake, Column C would say Sliced and Not Sliced for the Bread and Chocolate and Vanilla for the Cake. Colum D would then list all the kids of breads like white, wheat, etc...

He needs to transform it (via code, so it is repeatable) so that on a new sheet in column A it shows the unique items from Colum A and then it puts those same values across the top and then continues to drill down in that manner.

I know, it's odd and complicated.

I've attached a color-coded example for reference.

I can do the unique values from Column A with this code:

Code: Select all

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub
but that's where I am unsure how to continue.

And there can be number of L2 values for an L1, any number of L3s for an L2, and any number of L4s for an L3. Including zero.

Any pointers?

Thanks!
You do not have the required permissions to view the files attached to this post.
Morgan

User avatar
HansV
Administrator
Posts: 75203
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Very unusual data transformation

Post by HansV »

With a slightly different column order:

Code: Select all

Sub Transform()
    Const rs1 = 3  ' First row of input
    Const rt1 = 30 ' First row of output
    Const c1 = 2   ' First column of input & output
    Dim rs As Long
    Dim cs As Long
    Dim rm As Long
    Dim rt As Long
    Dim rt2 As Long
    Dim ct As Long
    Dim i As Long

    Application.ScreenUpdating = False

    Range(Cells(rt1, c1), Cells(rt1 + 100, c1 + 50)).Clear

    cs = c1 - 1
    rm = Cells(rs1, cs + 1).End(xlDown).Row
    ct = c1

    For i = 1 To 3
        rt = rt1
        rs = rs1
        cs = cs + 1
        Do
            If Cells(rs, cs).Value <> "" Then
                If i = 1 And Cells(rs, cs).Value <> Cells(rs - 1, c1).Value Then
                    rt = rt + 1
                    Cells(rs, cs).Copy Destination:=Cells(rt, c1)
                End If
                If Cells(rs, cs + 1).Value <> "" And Cells(rs, cs).Value <> Cells(rs - 1, cs).Value Then
                    ct = ct + 1
                    Cells(rs, cs).Copy Destination:=Cells(rt1, ct)
                    rt2 = rt1
                End If
                If Cells(rs, cs + 1).Value <> "" And Cells(rs, cs + 1).Value <> Cells(rs - 1, cs + 1).Value Then
                    rt2 = rt2 + 1
                    Cells(rs, cs + 1).Copy Destination:=Cells(rt2, ct)
                End If
            End If
            rs = rs + 1
        Loop Until rs > rm
    Next i

    Application.ScreenUpdating = True
End Sub
Regards,
Hans

User avatar
Abraxus
3StarLounger
Posts: 236
Joined: 01 Mar 2010, 17:34
Location: Blue Springs, MO

Re: Very unusual data transformation

Post by Abraxus »

Very elegant solution, thank you!

Waiting for him to confirm, but this should meet his needs.

It was was easy to modify to fit his specific formatting, too.
Morgan