Transpose values to specific columns

[Rudi]

Hi,

I committed myself to a thread on the Excel forum and I too am struggling to resolve this!?
Could I ask for some assistance here.

The original thread is found here:
http://www.excelforum.com/excel-program ... ost3680693

To simplify the concept, I have generated a smaller file to identify what is needed. I started and scrapped my code thrice and still cannot figure this one...!
Please see attached which explains the process that needs automation.

TX

[HansV]

Try this macro:

Code: Select all

Sub TransposeSubCats()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim s As Long
    Dim m As Long
    Dim t As Long
    Dim SubCat As Variant
    Dim i As Long
    Dim col As New Collection
    Dim n As Long
    Dim Counters() As Long
    Dim MaxCount As Long
    Set wshS = Worksheets("Before")
    m = wshS.Cells(wshS.Rows.Count, 1).End(xlUp).Row
    On Error Resume Next
    For s = 2 To m
        col.Add Item:=wshS.Cells(s, 4).Value, Key:=CStr(wshS.Cells(s, 4).Value)
    Next s
    On Error GoTo 0
    n = col.Count
    Application.ScreenUpdating = False
    Set wshT = Worksheets.Add(After:=wshS)
    wshS.Cells(1, 1).Resize(1, 3).Copy wshT.Cells(1, 1)
    For i = 1 To n
        wshT.Cells(1, i + 3).Value = col(i)
    Next i
    t = 2
    For s = 2 To m
        If wshS.Cells(s, 1).Value <> wshS.Cells(s - 1, 1).Value Or _
           wshS.Cells(s, 2).Value <> wshS.Cells(s - 1, 2).Value Or _
           wshS.Cells(s, 3).Value <> wshS.Cells(s - 1, 3).Value Then
            t = t + MaxCount
            ReDim Counters(1 To n)
            MaxCount = 0
        End If
        SubCat = wshS.Cells(s, 4).Value
        For i = 1 To n
            If col(i) = SubCat Then
                Counters(i) = Counters(i) + 1
                If Counters(i) > MaxCount Then
                    MaxCount = Counters(i)
                    wshS.Cells(s, 1).Resize(1, 3).Copy wshT.Cells(t + MaxCount - 1, 1)
                End If
                wshT.Cells(t + Counters(i) - 1, i + 3).Value = wshS.Cells(s, 5).Value
                Exit For
            End If
        Next i
    Next s
    Application.ScreenUpdating = True
End Sub

The result is different from the "After" sheet in cells D7:D8, I think they should be empty in the "After" sheet.

[Rudi]

Hans....this is amazing code!!

I learned a lot by stepping through and modifying the code to adjust to the actual workbook of the enquirer.
BTW: It works perfectly on that workbook to.

I love the use of: Dim col As New Collection. It seems to be an awesome way to get a unique list of items in a columns. I thought the easiest was to do this was using the Dictionary Object, but this is even better...
Also the use of the array called Counters() as amazing....

A big thumbs up and thank you!!

See my reply with your solution here

[Rudi]

The result is different from the "After" sheet in cells D7:D8, I think they should be empty in the "After" sheet.

You are correct. That was a little oversight on my part when I set up a smaller sample file to simulate the requirements.