VBA transpose rows of data into columns

Question

I googled this question, but nothing reasonalbe didn't pop out, and i don't have any clue, at the moment, how to do it. So, decided to write here.

I have large table, aprox. 300'000 rows, and between normal rows, i have some information, which needs to be transposed to rows. As a sample, this information looks like this:

If any ideas pops out, please, let me know. Best regards.

Answer 1

With so much data, I felt the process would execute more rapidly, as Jeeped mentioned, done in VBA arrays instead of on the worksheet. Here is a macro that does that. To tell where to start a new row, I looked at column 2 -- if column 2 is blank, then the data is appended to the previous row; if not, then a new row would start.

Other types of testing could be substituted.

---

Option Explicit
Sub TransposeSomeRows()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim I As Long, J As Long, K As Long

    Dim lRowCount As Long, lColCount As Long

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc.Cells
    lRowCount = .Find(what:="*", after:=.Item(1, 1), LookIn:=xlValues, _
        searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    lColCount = .Find(what:="*", after:=.Item(1, 1), _
        searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With

'Read source data into array
With wsSrc
    vSrc = .Range(.Cells(2, 1), .Cells(lRowCount, lColCount))
End With

'create results array
'Num of rows = number of items in Column 2
lRowCount = WorksheetFunction.CountA(wsSrc.Columns(2))

'Num of columns = max of entries in a "start row" plus blanks to next "start row"
lColCount = 0
For I = 1 To UBound(vSrc, 1)
    If vSrc(I, 2) <> "" Then
        For J = 1 To UBound(vSrc, 2)
            If vSrc(I, J) <> "" Then K = J
        Next J
    Else 'vSrc(i,2) = "" so add a column
        K = K + 1
    End If

    lColCount = IIf(lColCount > K, lColCount, K)

Next I


ReDim vRes(1 To lRowCount, 1 To lColCount)

'Populate results array
K = 0
For I = 1 To UBound(vSrc, 1)
    If vSrc(I, 2) <> "" Then
        K = K + 1
        J = 1
        For J = 1 To UBound(vSrc, 2)
            If vSrc(I, J) <> "" Then
                vRes(K, J) = vSrc(I, J)
            Else
                Exit For
            End If
        Next J
    Else
        vRes(K, J) = vSrc(I, 1)
        J = J + 1
    End If
Next I

'Write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub

---

Answer 2

300,000 rows is going to take some time to process but this may run through fairly quickly.

Sub duplicate()
    Dim rw As Long, nrw As Long

    Application.ScreenUpdating = False

    With Worksheets("Sheet1")   '<~~ set this worksheet properly!
        For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If Not IsNumeric(.Cells(rw, 1).Value2) Then
                nrw = Application.Match(1E+99, .Cells(1, 1).Resize(rw - 1, 1))
                .Cells(nrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 1).Value2
                .Rows(rw).Delete
            Else
                With .Rows(rw)
                    .Cells.Sort Key1:=.Cells(1), Order1:=xlAscending, _
                        Orientation:=xlLeftToRight, Header:=xlNo
                End With
            End If
        Next rw
    End With

    Application.ScreenUpdating = True

End Sub

Faster processing could likely be achieved with processing variant memory arrays but this should get the job done.

Answer 3

I liked Jeeped solution, but it seems to reorder the data witch might not be desired. Here is my proposed solution, I haven't benchmarked so I can't tell if it is really slower.

Public Sub Test()
    Dim lastRow As Long, firstRow As Long, lastCell As Range, rng As Range
    Dim currentRow As Long
    Application.ScreenUpdating = False
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For currentRow = lastRow To 1 Step -1
        If IsNumeric(Cells(currentRow, 1).Value) Then
            Set lastCell = Cells(currentRow, 1).End(xlToRight).Offset(0, 1)

            Set rng = Range(Cells(firstRow, 1), Cells(lastRow, 1))
            rng.Copy
            lastCell.PasteSpecial Transpose:=True
            rng.EntireRow.Delete
            lastRow = currentRow - 1
        Else
            firstRow = currentRow
        End If
    Next currentRow
    Application.ScreenUpdating = False
End Sub

I've come up with another version mixing Jeeped and mine:

Public Sub Test2(Optional ws As Worksheet)
    Dim lastRow As Long, lastCell As Range, rng As Range
    Dim currentRow As Long

    Application.ScreenUpdating = False

    If ws Is Nothing Then Set ws = ActiveSheet

    Dim BigestValue As Variant
    BigestValue = ws.Evaluate([MAX(A:A)])
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    For currentRow = lastRow To 1 Step -1
        If Not IsNumeric(ws.Cells(currentRow, 1).Value) Then
            'look up for last numeric cell
            lastRow = currentRow
            currentRow = Application.Match(BigestValue, ws.Cells(1, 1).Resize(currentRow, 1))
            Set lastCell = ws.Cells(currentRow, 1).End(xlToRight).Offset(0, 1)
            Set rng = Range(ws.Cells(currentRow + 1, 1), ws.Cells(lastRow, 1))
            rng.Copy
            lastCell.PasteSpecial Transpose:=True
            rng.EntireRow.Delete
        End If
    Next currentRow

    Application.ScreenUpdating = True
End Sub

Answer 4

You can use the PasteSpecial function with Transpose:=True. For example:

Range("A2:A5").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

would transpose A2:A5 to E2:

Answer 5

First define which rows have to be Transposed! Is there only the first row filled with values? Or are the values numeric? Is the result in a new or the same worksheet?

You can use a for loop from first row to last row:

Find out the Cell where the transposed range is inserted. Then check which ranges have to be transposed. Use long variables for the first and last row You want to transpose. When a new row with values comes, cut the range and paste it into the desired cell

U can use the the macro recorder to see how to transpose a range. Or Look at the other answers.

If you delete the rows it is better to create a new Worksheet or Loop from bottom to Top