Transpose Excel column to rows

Question

I have an Excel sheet that looks like the first picture and I want to convert it to the second picture:

I have written the following code but it does not work as ex

Answer 1

So I did a little refactoring. I moved everything into arrays to speed it up.

See notes in code for reference.

Sub FOOO()
Dim inArr() As Variant
Dim outArr() As Variant
Dim ws As Worksheet
Dim cntrw As Long
Dim cntclm As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim rng As Range

Set ws = ActiveSheet

With ws
    Set rng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
    'find the max number column that will be needed in the output
    cntclm = ws.Evaluate("MAX(COUNTIF(" & rng.Address & "," & rng.Address & "))") + 1
    'find the number of rows that will be needed in the output.
    cntrw = ws.Evaluate("SUM(1/COUNTIF(" & rng.Address & "," & rng.Address & "))")
    'put the existing data into an an array
    inArr = rng.Resize(, 2).Value
    'resize output array to the extents needed
    ReDim outArr(1 To cntrw, 1 To cntclm)
    'put the first value in the first spot in the output
    outArr(1, 1) = inArr(1, 1)
    outArr(1, 2) = inArr(1, 2)
    'these are counters to keep track of which slot the data should go.
    j = 3
    k = 1
    'loop through the existing data rows
    For i = 2 To UBound(inArr, 1)
        'test whether the data in A has changed or not.
        If inArr(i, 1) = inArr(i - 1, 1) Then
            'if not put the value in B in the next slot and iterate to the next column
            outArr(k, j) = inArr(i, 2)
            j = j + 1
        Else
            'if change start a new line in the outarr and fill the first two slots
            k = k + 1
            j = 3
            outArr(k, 1) = inArr(i, 1)
            outArr(k, 2) = inArr(i, 2)
        End If
    Next i
    'remove old data
    .Range("A:B").Clear
    'place new data in its place.
    .Range("A1").Resize(UBound(outArr, 1), UBound(outArr, 2)).Value = outArr
End With
End Sub

This does require that the data be sorted on column A.

Answer 2

My take on this problem .

Sub test()

    Dim lCtrRow_Raw     As Long
    Dim lCtrRow_New     As Long
    Dim lInst           As Long

    Dim dctUniq         As New Dictionary
    Dim sKey
    Dim arrRaw
    Dim arrNew()

    '/ Specify your range here. Only two columns of data should be used.
    arrRaw = Selection() ' ****Avoid using Selection in actual code****.

    '/ Filter Duplicates.
    For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw)
        If Not dctUniq.Exists(arrRaw(lCtrRow_Raw, 1)) Then
            dctUniq.Add arrRaw(lCtrRow_Raw, 1), arrRaw(lCtrRow_Raw, 1)
        End If
    Next

    '/ Start New Array
    ReDim arrNew(1 To dctUniq.Count, 1 To 1)

    '/ Seed IDs
    For Each sKey In dctUniq.Keys
        lCtrRow_New = lCtrRow_New + 1
        arrNew(lCtrRow_New, 1) = dctUniq(sKey)
    Next

    '/ Loop and assign unique values
    For lCtrRow_New = LBound(arrNew) To UBound(arrNew)
      lInst = 1
     For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw)
            If arrRaw(lCtrRow_Raw, 1) = arrNew(lCtrRow_New, 1) Then
                lInst = lInst + 1
                If lInst > UBound(arrNew, 2) Then
                    ReDim Preserve arrNew(1 To dctUniq.Count, 1 To lInst)
                End If

                arrNew(lCtrRow_New, lInst) = arrRaw(lCtrRow_Raw, 2)
            End If
       Next
    Next

    '/ Dump array in the data sheet.
    'Sheet1.Range("A20").Resize(UBound(arrNew, 1), UBound(arrNew, 2)).Value = arrNew
End Sub

Answer 3

Shank, using your code, I've made minor modifications and now it deletes the right number of rows and it works, try it out.

Sub Transpose()

Dim sht As Worksheet
Dim LastRow As Long

Set sht = ThisWorkbook.Worksheets("Sheet_Name") ' modify here to your Worksheet name
LastRow = sht.Cells(sht.Rows.count, "A").End(xlUp).row

    For row = 1 To LastRow
        If sht.Cells(row, 1) <> "" Then
            i = i + 1
            j = i
            Z = 1
            Do While Cells(j + 1, 1).Value = Cells(j, 1).Value
                j = j + 1
            Loop

            Set rng2 = Range("B" & i & ":B" & j)

            If i > 1 Then
                Z = j - i + 1
            Else
                Z = j
            End If

            rng2.Resize(Z).Copy
            Range("C" & i).PasteSpecial Transpose:=True
            T = i

            Do While j - row > 0
                Q = T + 1
                Rows(Q).EntireRow.Delete
                j = j - 1
            Loop
        End If
    Next

End Sub