Pivot/transpose ??

[Emm]

Hi All,

I have a list of materials that has about 10,000 items.
These Items have about 50 Categories.
I want to pivot or transpose the data so I can create validation lists using the categories as headers.

Example: as existing List

CAT ITEM
Fruit Banana
Fruit Apple
Vege Carrot
Vege Potato


As Validation List

FRUIT VEGE
Banana Carrot
Apple Potato

I'm currently using Extract Unique to create CAT headers,
then filtering the list on each category to copy and paste the items under the headers,
then Name the ranges using CAT names.

It is a case of press the button, then go make the coffee ... VERY slow..

Is there a faster way?

Thanks

Keith

 

[Fluff]

How about this

Sub CopyTranspose()

    Dim Cl As Range
    Dim Dict As Object
    Dim Ky As Variant
    Dim col As Long
    
Application.ScreenUpdating = False

    Set Dict = CreateObject("scripting.dictionary")
    
    With Sheets("[COLOR=#0000ff]Records[/COLOR]")
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If Not Dict.exists(Cl.Value) Then
                Dict.Add Cl.Value, Cl.Offset(, 1).Value
            Else
                Dict.Item(Cl.Value) = Dict.Item(Cl.Value) & "|" & Cl.Offset(, 1).Value
            End If
        Next Cl
    End With
    col = 1
    With Sheets("[COLOR=#0000ff]New[/COLOR]")
        .Range("A1").Resize(, Dict.Count).Value = Dict.keys
        For Each Ky In Dict.items
        .Cells(2, col).Resize(UBound(Split(Ky, "|"))).Value = Application.Transpose(Split(Ky, "|"))
        col = col + 1
        Next Ky
    End With
    
End Sub

Changing sheets names in blue to suit

 

[Emm]

Wow !!! ... that is so fast Fluff ...
Fantastic.... now I wont have to drink so much coffee

Thankyou ...

Not sure how it does it, but will try and figure it out..

Keith

 

[Emm]

How about this

Sub CopyTranspose()

    Dim Cl As Range
    Dim Dict As Object
    Dim Ky As Variant
    Dim col As Long
    
Application.ScreenUpdating = False

    Set Dict = CreateObject("scripting.dictionary")
    
    With Sheets("[COLOR=#0000ff]Records[/COLOR]")
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If Not Dict.exists(Cl.Value) Then
                Dict.Add Cl.Value, Cl.Offset(, 1).Value
            Else
                Dict.Item(Cl.Value) = Dict.Item(Cl.Value) & "|" & Cl.Offset(, 1).Value
            End If
        Next Cl
    End With
    col = 1
    With Sheets("[COLOR=#0000ff]New[/COLOR]")
        .Range("A1").Resize(, Dict.Count).Value = Dict.keys
        For Each Ky In Dict.items
        .Cells(2, col).Resize(UBound(Split(Ky, "|"))).Value = Application.Transpose(Split(Ky, "|"))
        col = col + 1
        Next Ky
    End With
    
End Sub

Changing sheets names in blue to suit

Hi Fluff,

I have it working well except for one thing..
I'm missing the last row in each category (record)
I cant seem to find the adjustment required ...
Can you help?

Thanks,

Keith

 

[Fluff]

Make the change shown here in red

        .Cells(2, col).Resize(UBound(Split(Ky, "|"))[COLOR=#ff0000] + 1[/COLOR]).Value = Application.Transpose(Split(Ky, "|"))

 

[Emm]

Make the change shown here in red

        .Cells(2, col).Resize(UBound(Split(Ky, "|"))[COLOR=#ff0000] + 1[/COLOR]).Value = Application.Transpose(Split(Ky, "|"))

You are a LEGEND ... thank you...

 

[Fluff]

Glad to help & thanks for the feedback