Move certain row of data into column

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

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

Answer 2

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