Excel Convert Multiple Rows into Multiple Columns

[james.y.so]

Hi All,

I need some help with converting my excel data from multiple rows to
multiple columns. Say i have a long list of serial numbers in a single
column, like this:

10000
10001
10002
10003
10004
10005
10006
.....
19999

How can i convert it to columns of data, like this?

10000 10005 10010 .....
10001 10006 10011 ....
10002 10007 10012 ....
10003 10008 10013 ....
10004 10009 10014 ....

I need each column having a specific numbers of rows, say 40, before
the data continues to the next column.

Thanks in advance!

 

[Gary Keramidas]

here is something i use. it uses sheet 1 and assumes column A has a header, data
starts in A2 and you want the data in consecutive columns, 48 rows long.
watch for word wrap on the post.

Option Explicit

Sub Split_Col()
Dim ws2 As Worksheet
Dim i As Long, z As Long
Dim lastrow As Long
Dim colGroup As Long
Dim remainder As Long
Set ws2 = Worksheets("Sheet1")
lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
colGroup = (lastrow - 1) \ 48 ' determine number of groups
remainder = (lastrow - 1) Mod 48 ' partial group
Debug.Print colGroup & " " & remainder
z = 1
On Error Resume Next
For i = colGroup To 1 Step -1
If i > 1 Then
ws2.Range("A50:A50").Resize(48).Copy
ws2.Cells(2, z + 1).PasteSpecial xlPasteAll
ws2.Rows("50").Resize(48).EntireRow.Delete
ws2.Range("A1:A1").Copy
ws2.Cells(1, z + 1).PasteSpecial xlPasteAll
ws2.Columns(z + 1).Resize(, 1).AutoFit
z = z + 1
Else
If remainder = 0 Then GoTo Xit
ws2.Range("A50:A50").Resize(remainder).Copy
ws2.Cells(2, z + 1).PasteSpecial xlPasteAll
ws2.Rows("50").Resize(remainder).EntireRow.Delete
ws2.Range("A1:A1").Copy
ws2.Cells(1, z + 1).PasteSpecial xlPasteAll
ws2.Columns(z + 1).Resize(, 1).AutoFit
End If
Next

Xit:
ws2.Range("A1").Copy
ws2.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
With ws2.Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
Application.ScreenUpdating = True
End Sub

 

[james.y.so]

Hi Gary,

Thank you for the quick reply and it works well.

Just wondering though, if i don't want the header, and my data starts
at A1 cell. How should the coding be? Also i need the number of data
in a column to be 40 instead of 48.

Appreciate your help again because i know nothing about programming.
Thanks!

 

[NickHK]

Here's one way, slightly tested:

Private Sub CommandButton1_Click()
Const MAX_ROWS As Long = 40

Debug.Print "Columns Used: " & RearrangeData(Range(Range("A1"),
Range("A1").End(xlDown)), MAX_ROWS)

End Sub

Private Function RearrangeData(DataInColumn As Range, MaxRows As Long,
Optional ConvertToValues As Boolean = True) As Long
Dim FormulaStr As String
Dim ColumnCount As Single
Dim DestRange As Range

Const Formul As String =
"=OFFSET(FIRST_CELL,(ROW()-1+(COLUMN()-1)*MAX_ROWS),0)"

FormulaStr = Replace(Formul, "FIRST_CELL", DataInColumn(1).Address)
FormulaStr = Replace(FormulaStr, "MAX_ROWS", MaxRows)

ColumnCount = DataInColumn.Rows.Count / MaxRows
If ColumnCount <> Int(ColumnCount) Then
ColumnCount = Int(ColumnCount)
Else
ColumnCount = ColumnCount - 1
End If

Set DestRange = DataInColumn(1).Offset(0, 1).Resize(MaxRows, ColumnCount)

With DestRange
.Formula = FormulaStr
If ConvertToValues = True Then
.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
End If
End With

RearrangeData = ColumnCount

End Function

NickHK

 

[Gary Keramidas]

give this a try:

Option Explicit
Sub Split_Col()
Dim ws2 As Worksheet
Dim i As Long, z As Long, q As Long
Dim lastrow As Long
Dim colGroup As Long
Dim remainder As Long
Set ws2 = Worksheets("Sheet1")
lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
colGroup = (lastrow - 1) \ 40 ' determine number of groups
remainder = (lastrow - 1) Mod 40 ' partial group
Debug.Print colGroup & " " & remainder
z = 1
On Error Resume Next
For i = colGroup To 1 Step -1
If i > 1 Then
ws2.Range("A41:A41").Resize(40).Copy
ws2.Cells(1, z + 1).PasteSpecial xlPasteAll
ws2.Rows("41").Resize(40).EntireRow.Delete
ws2.Columns(z + 1).Resize(, 1).AutoFit
z = z + 1
Else
If remainder = 0 Then GoTo Xit
ws2.Range("A41:A41").Resize(remainder + 1).Copy
ws2.Cells(1, z + 1).PasteSpecial xlPasteAll
ws2.Rows("41").Resize(remainder + 1).EntireRow.Delete
ws2.Columns(z + 1).Resize(, 1).AutoFit
End If
Next
Xit:
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[Alan Beban]

If the functions in the freely downloadable file at
http://home.pacbell.net/beban are available to your workbook:

x = 1 + InputRange.Count \ 40
Set OutputRange = Range("C1").Resize(40, x)
OutputRange.Value = ArrayReshape(InputRange, 40, x, 1)

Alan Beban

 

[james.y.so]

give this a try:

Option Explicit
Sub Split_Col()
Dim ws2 As Worksheet
Dim i As Long, z As Long, q As Long
Dim lastrow As Long
Dim colGroup As Long
Dim remainder As Long
Set ws2 = Worksheets("Sheet1")
lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
colGroup = (lastrow - 1) \ 40 ' determine number of groups
remainder = (lastrow - 1) Mod 40 ' partial group
Debug.Print colGroup & " " & remainder
z = 1
On Error Resume Next
For i = colGroup To 1 Step -1
If i > 1 Then
ws2.Range("A41:A41").Resize(40).Copy
ws2.Cells(1, z + 1).PasteSpecial xlPasteAll
ws2.Rows("41").Resize(40).EntireRow.Delete
ws2.Columns(z + 1).Resize(, 1).AutoFit
z = z + 1
Else
If remainder = 0 Then GoTo Xit
ws2.Range("A41:A41").Resize(remainder + 1).Copy
ws2.Cells(1, z + 1).PasteSpecial xlPasteAll
ws2.Rows("41").Resize(remainder + 1).EntireRow.Delete
ws2.Columns(z + 1).Resize(, 1).AutoFit
End If
Next
Xit:
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Got it now. Works perfectly. Thanks!