Переместить определенную строку данных в столбец

Question

Если у меня есть все данные в одном очень длинном столбце, например:

 A
 B
 C
 1
 2
 3

 D
 E
 F
 4
 5
 6

 G
 H
 I
 7
 8
 9

Возможно ли переместить данные следующим образом?

Column1  Column2  Column3  Column4  Column5  Column6
A        B        C        1        2        3
D        E        F        4        5        6
G        H        I        7        8        9

Я пытался вставить команду special + transpose, но у меня более 10 тысяч записей, поэтому использование этого метода займет у меня слишком много времени.

Я новичок в Excelи макрос, большое спасибо.

Редактировать:

Я даже пытался перенести все данные во многие столбцы, затем выбрать столбец, который я хочу превратить их в один столбец с помощью этого макроса:

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

Но он просто объединит все столбцы в один, а не выбранный столбец.

Для справки по Рему:

Вот вывод:

 A   D   G

 B   E   H

 C   F   I

 1   4   7

 2   5   8

 3   6   9  

Answer 1

Вот как я делаю то же самое ... он создает новую таблицу в столбце C над ... на основе вашего примера, что между каждой группой данных есть пустая ячейка:

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

Это должно работать для любой длины данных и «групп» до 8500 данных.

При этом также используется метод AREAS, но он преодолевает ограничение групп с помощью подгрупп, поэтому он должен работать с набором данных любого размера.

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

Вы можете посмотреть на что-то в этих строках:

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