Move certain row of data into column - vba

Question

If I have all data in one very long column like this:
A
B
C
1
2
3
D
E
F
4
5
6
G
H
I
7
8
9
Is it possible to move data like this?
Column1 Column2 Column3 Column4 Column5 Column6
A B C 1 2 3
D E F 4 5 6
G H I 7 8 9
I tried paste special+transpose , but I have more than 10 thousands records , so it will take me too much time in using this method.
I'm new in excel and macro , thank you very much.
Edit:
I even tried to transpose all data into many columns then select the column I want to make them all into one column with this macro:
Sub OneColumn()
' Jason Morin as amended by Doug Glancy
' http://makeashorterlink.com/?M19F26516
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length
'into 1 continuous column in a new sheet
''''''''''''''''''''''''''''''''''''''''''
Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws_from = ActiveWorkbook.ActiveSheet
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column
'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0
'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"
For from_colndx = 1 To from_lastcol
from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
'If you're going to exceed 65536 rows
If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
Else
MsgBox "This time you've gone to far"
Exit Sub
End If
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next
' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it will just join all column into one but not the column selected.
For Remou reference:
Here is the output:
A D G
B E H
C F I
1 4 7
2 5 8
3 6 9

Answer 1

You can look at something in these lines:
Sub TransposeColumn()
Dim rng As Range
Dim ws As Worksheet
Set rng = Worksheets("Input").UsedRange
Set ws = Worksheets("Output")
j = 1
k = 1
For i = 1 To rng.Rows.Count
If rng.Cells(i, 1) = vbNullString Then
j = j + 1
k = 1
Else
''ws.Cells(k, j) = rng.Cells(i, 1)
''EDIT
ws.Cells(j, k) = rng.Cells(i, 1)
k = k + 1
End If
Next
End Sub

Answer 2

This is how I do the same thing... it creates the new table in column C over...based on your example that there is a blank cell between each group of data:
Sub TransposeGroups()
Dim RNG As Range, Grp As Long, NR As Long
Set RNG = Range("A:A").SpecialCells(xlConstants)
NR = 1
For Grp = 1 To RNG.Areas.Count
RNG.Areas(Grp).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Grp
End Sub
This should work for any length of data and "groups" of up to 8500 within the data.
This also uses the AREAS method, but this overcomes the groups limitation by using subgroups, so it should work with any size dataset.
Sub TransposeGroups2()
'Uses the AREAS method and will work on any size data set
'overcomes the limitation of areas by working in subgroups
Dim RNG As Range, rngSTART As Range, rngEND As Range
Dim LR As Long, NR As Long, SubGrp As Long, Itm As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
NR = 1
SubGrp = 1
Set rngEND = Range("A" & SubGrp * 10000).End(xlUp)
Set RNG = Range("A1", rngEND).SpecialCells(xlConstants)
Do
For Itm = 1 To RNG.Areas.Count
RNG.Areas(Itm).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Itm
If rngEND.Row = LR Then Exit Do
Set rngSTART = rngEND.Offset(1)
SubGrp = SubGrp + 1
Set rngEND = Range("A" & (SubGrp * 10000)).End(xlUp)
Set RNG = Range(rngSTART, rngEND).SpecialCells(xlConstants)
Loop
End Sub