Transposing ranges separated by blanks rows-CodePudding

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

[ See Here

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

Any input appreciated.

CodePudding user response：

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

CodePudding user response：

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

CodePudding user response：

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.