Transpose to break up one long row to many?

  • Thread starter Thread starter Andym
  • Start date Start date
A

Andym

Hi All
I have a problem i hope you can help with. The sheet i have has rows of many
columns, what i need to do is leave the first 5 columns of data and
underneath that row insert the next 5 columns of data, then the same again
with 4 columns, 5 columns, 4 columns. One the has done move to the next
original row and repeat till the end. Any suggestiosn on a macro to help?
Thanks
 
Try this to move in blocks of 5

Option Explicit
Sub breakrowtorows()
Dim i As Long
Dim j As Long
Dim r As Long

Application.ScreenUpdating = False
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
r = 1
For j = 1 To Cells(i, Columns.Count).End(xlToLeft).Column Step 5
Cells(i, j).Resize(, 5).Copy
Cells(i + r, 1).Insert Shift:=xlDown
r = r + 1
Next j
Rows(i).Delete
Next i
Application.ScreenUpdating = True
End Sub
 
'You could try this one. Note that you need to state what rows range to
cover. It
'currently is set to transpose rows 4 through 5

'===============
Sub Reorder()
Dim i, x, j, xOffset As Double

'Which rows to transpose?
For i = 5 To 4 Step -1

x = 6
j = 10
xOffset = 1
'Go until the 23rd column of data
While j < 23

Range(Cells(i, x), Cells(i, j)).Cut
Cells(i + xOffset, "A").Insert shift:=xlDown
If j - x = 3 Then
'If a shorter segment, shift leftover cells
Cells(i + xOffset, 5).Insert shift:=xlDown
End If
'alternate grabbing 4 of 5 columns
If j - x = 4 Then
x = j + 1
j = x + 3
Else
x = j + 1
j = x + 4
End If
xOffset = xOffset + 1
Wend
Next
End Sub
'================
 
Back
Top