Transposing ranges separated by blanks rows - excel

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

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

Answer 2

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 3

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 4

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