Transposing ranges separated by blanks rows

Question

I've been trying to tinker with this source code that transposes 1 column separated by spaces.

Sub Transpose()

Dim lastrow As Long, i As Long, j As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With Sheets("Sheet1")
    Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
    lastrow = .Cells(Rows.Count, "A").End(xlUp).row
    iStart = 1
    For i = 1 To lastrow + 1
        If .Range("A" & i).Value = "" Then
            iEnd = i
            j = j + 1
            .Range(.Cells(iStart, 1), .Cells(iEnd, 1)).Copy
            ws.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

I'm trying to take take 4 columns ranges with variable rows

[

And transpose each range adjacently so that it looks like this:

Any input appreciated.

Answer 1

Transpose Groups of Data to a New Worksheet

Sub TransposeGroups()
    
    ' Source - use as-is (read (copy) from)
    Const sName As String = "Sheet1"
    Const sFirstRowAddress As String = "A1:D1"
    Const sMandatoryColumnIndex As Long = 1 ' dictates if empty row (gap)
    ' Destination - delete if exists and put last (write (paste) to)
    Const dName As String = "Result"
    Const dFirstCellAddress As String = "A1"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the values from the source range to a 2D one-based array
    ' and write its upper limits to variables.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim sData As Variant
    Dim srCount As Long
    Dim scCount As Long
    
    With sws.Range(sFirstRowAddress)
        Dim lCell As Range
        With .Columns(sMandatoryColumnIndex)
            Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
                .Find("*", , xlFormulas, , , xlPrevious)
        End With
        If lCell Is Nothing Then
            MsgBox "No data in column " & sMandatoryColumnIndex & ".", _
                vbCritical
            Exit Sub
        End If
        scCount = .Columns.Count
        srCount = lCell.Row - .Row + 1
        sData = .Resize(srCount).Value
    End With
        
    ' Loop through the rows of the source array and map the first row,
    ' the last row and the following gap count (empty rows) in each row
    ' of three columns of another 2D one-based array.
    ' Note that this array has the same number of rows as the source array,
    ' but the data of interest will be in much fewer rows ('mr').
    ' (Probably a collection of collections (or three element arrays)
    ' would have been a better choice.)
    
    Dim mArr() As Long: ReDim mArr(1 To srCount, 1 To 3)
        
    Dim sr As Long
    Dim sValueFound As Boolean
    Dim mr As Long
    Dim ccCount As Long
    Dim dcCount As Long
    Dim GapCount As Long
     
    For sr = 1 To srCount
        If Len(CStr(sData(sr, sMandatoryColumnIndex))) > 0 Then
            If Not sValueFound Then
                mr = mr + 1
                mArr(mr, 1) = sr ' first row
                sValueFound = True
            End If
        Else
            If sValueFound Then
                sValueFound = False
                mArr(mr, 2) = sr - 1 ' last row
                ccCount = sr - mArr(mr, 1)
                If ccCount > dcCount Then dcCount = ccCount
            End If
            mArr(mr, 3) = mArr(mr, 3) + 1 ' gap
            GapCount = GapCount + 1 ' to determine the number of rows of 'dData'
        End If
    Next sr
    
    ' The very last row (of interest).
    mArr(mr, 2) = srCount
    ccCount = sr - mArr(mr, 1)
    If ccCount > dcCount Then dcCount = ccCount
                
    ' Using the source array and the information from the mapping array,
    ' write the results to the destination array.
    
    Dim drCount As Long: drCount = mr * scCount + GapCount
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    Dim drFirst As Long
    
    Dim sc As Long
    Dim dc As Long
    
    For mr = 1 To mr
        For sc = 1 To scCount
            For sr = mArr(mr, 1) To mArr(mr, 2)
                dc = dc + 1
                dData(drFirst + sc, dc) = sData(sr, sc)
            Next sr
            dc = 0
        Next sc
        drFirst = drFirst + sc + mArr(mr, 3) - 1
    Next mr
                
    ' Write the values from the destination array to a new worksheet.
                
    ' Check if a sheet with the same name exists.
    Dim dsh As Object
    On Error Resume Next
        Set dsh = wb.Sheets(dName)
    On Error GoTo 0
    
    ' If it exists, delete it without confirmation.
    If Not dsh Is Nothing Then
        Application.DisplayAlerts = False
        dsh.Delete
        Application.DisplayAlerts = True
    End If
    
    ' Add a new worksheet and rename it accordingly.
    Dim dws As Worksheet
    Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    dws.Name = dName
    
    ' Write the values from the destination array to the destination worksheet.
    With dws.Range(dFirstCellAddress)
        .Resize(drCount, dcCount).Value = dData
    End With
    
    ' Inform.
    
    MsgBox "Groups transposed.", vbInformation
                
End Sub

Answer 2

Try this code:

Sub SubRollData()
    
    'Declarations.
    Dim RngSource As Range
    Dim RngTarget As Range
    Dim DblRowOffset As Double
    Dim DblColumnOffset As Double
    
    'Settings.
    Set RngSource = Range("A1")
    Set RngTarget = Range("F1")
    
    'Checkpoint for the block processing.
CP_Block:
    
    'Covering each column.
    For DblColumnOffset = 0 To 3
        
        'Setting DblRowOffset to start covering for the first row of the block.
        DblRowOffset = 0
        
        'Covering each row of the block of the given column until an empty cell is fount.
        Do Until RngSource.Offset(DblRowOffset, DblColumnOffset) = ""
            
            'Reporting the data with switched offset.
            RngTarget.Offset(DblColumnOffset, DblRowOffset).Value = RngSource.Offset(DblRowOffset, DblColumnOffset).Value
            
            'Setting DblRowOffset for the next row.
            DblRowOffset = DblRowOffset + 1
            
        Loop
    Next
    
    'Setting RngSource to aim at the next block.
    If RngSource.Offset(1, 0) = "" Then
        Set RngSource = RngSource.Offset(2, 0)
    Else
        Set RngSource = RngSource.End(xlDown).Offset(2, 0)
    End If
    
    'Setting RngSource to aim at the next empty row to fill in with data.
    If RngTarget.Offset(1, 0) = "" Then
        Set RngTarget = RngTarget.Offset(1, 0)
    Else
        Set RngTarget = RngTarget.End(xlDown).Offset(1, 0)
    End If
    
    'If RngSource has no data, there is no more block to be processed. Otherwise, the next block is processed.
    If RngSource.Value <> "" Then GoTo CP_Block
    
End Sub

It works with the example you've given and also with isoletd (single row) source data.

---

Just for fun, here is a possible formula based solution to be placed in cell F1 and dragged:

=IF(COLUMN(F1)-COLUMN($F1)+1>=AGGREGATE(15,6,1/($A:$A="")*ROW($A:$A),QUOTIENT(ROW(F1)-ROW(F$1),4)+1)-IF(QUOTIENT(ROW(F1)-ROW(F$1),4)=0,0,AGGREGATE(15,6,1/($A:$A="")*ROW($A:$A),QUOTIENT(ROW(F1)-ROW(F$1),4))),"",INDEX($A:$D,COLUMN(F1)-COLUMN($F1)+1+IF(QUOTIENT(ROW(F1)-ROW(F$1),4)=0,0,AGGREGATE(15,6,1/($A:$A="")*ROW($A:$A),QUOTIENT(ROW(F1)-ROW(F$1),4))),MOD(ROW(F1)-ROW(F$1),4)+1))

Naturally it's really heavy and stupidly complicated, but as i said: made it just for fun.

Answer 3

Took way too long to do this and the most atrocious architecture but it works.

r = 1
c = 1
cl = 6
rw = 1

For r = 1 To 13
    For c = 1 To 4
        If Cells(r, c) <> "" Then
            Cells(rw, cl) = Cells(r, c)
            rw = rw + 1
        End If
    Next
    'If Cells(r, c) = "" Then cl = 6
    rw = 1
    cl = cl + 1

Next

rw = 5
cl = 6

For r = 1 To 4
    For c = 10 To 12
        Cells(rw, cl) = Cells(r, c)
        cl = cl + 1
    Next
        rw = rw + 1
        cl = 6
Next

rw = 9
cl = 6

For r = 1 To 4
    For c = 14 To 18
        Cells(rw, cl) = Cells(r, c)
        cl = cl + 1
    Next
        rw = rw + 1
        cl = 6
Next

Range("J1:R4").ClearContents

Answer 4

Try this out:

Sub Transpose()

    Dim ws As Worksheet, cCopy As Range, cPaste As Range
    
    Set ws = Sheets("Sheet1")
    
    Set cCopy = ws.Range("A1")   'top-left of first data block
    Set cPaste = ws.Range("F1")  'first output cell
    
    Do While Len(cCopy.Value) > 0  'while have data to transpose
        
        With cCopy.CurrentRegion
            Debug.Print "Copying", .Address, " to ", cPaste.Address
            cPaste.Resize(.Columns.Count, .Rows.Count) = _
                          Application.Transpose(.Value)
            Set cPaste = cPaste.Offset(.Columns.Count + 1) 'next paste position
            Set cCopy = cCopy.Offset(.Rows.Count + 1)      'next data block
        End With
    Loop
    
End Sub