将某一行数据移动到列中

如果我有这样一个很长的列中的所有数据：

A B C 1 2 3 D E F 4 5 6 G H I 7 8 9 

可以像这样移动数据吗？

 Column1 Column2 Column3 Column4 Column5 Column6 ABC 1 2 3 DEF 4 5 6 GHI 7 8 9 

我试过粘贴特殊+转置，但我有超过10万条logging，所以这将花费我太多的时间来使用这种方法。

我是新手，擅长macros观，非常感谢。

编辑：

我甚至试图将所有的数据转换成许多列，然后select我想要使它们全部与这个macros一列的列：

 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 

但是它只会将所有列join到一个列中，而不是所选的列。

对于Remou参考：

这是输出：

  ADG BEH CFI 1 4 7 2 5 8 3 6 9 

Answer 1

你可以看看这些内容：

 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

这就是我如何做同样的事情…它创build列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