Question

如果我在一个非常长的列中包含所有数据，请执行以下操作：

是否可以像这样移动数据？

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

我尝试粘贴特殊+转置，但我有超过10万条记录，因此使用此方法需要花费太多时间。

我是excel和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

但它只会将所有列加入一个而不是所选的列。

对于Remou参考：

这是输出：

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

这就是我做同样的事情......它根据你的例子在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

将某行数据移动到列中

2 个答案: