VBA：剪切一系列的列并将其粘贴为一列

我很新，非常感谢你的帮助。 我有14000列的数据，每行大约30行。

我需要将每一列粘贴在一起，这样我只剩下一列。 我提供了一个示例屏幕截图：

我在VBA代码的尝试如下（这是行不通的）：

Sub Cut() Dim i As Integer For i = 1 To 14000 Col = Columns(i).Select Range("N2:N31").Offset(, i).Select Selection.Cut Range("H2").End(xlDown).Offset(1).Row.Select ActiveSheet.Paste Next i End Sub 

请帮忙。 谢谢

Answer 1

而不是复制范围，您可以将值分配给范围

 Sub ConvertRangeToColumn() Dim ws As Worksheet Dim lastColumn As Long, lastRow As Long Dim rng As Range Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to yout data sheet With ws lastColumn = Cells(1, Columns.Count).End(xlToLeft).Column 'get last column using Row 1 For i = 5 To lastColumn 'loop though each column starting from 5 Set rng = .Range(.Cells(2, i), .Cells(.Cells(.Rows.Count, i).End(xlUp).Row, i)) 'set range to copy .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(rng.Rows.Count).Value = rng.Value Next i End With Application.ScreenUpdating = True End Sub 

Answer 2

试试这个，假设你的数据从第一行开始。

 Sub Cut() Dim c As Long Application.screenupdating=false For c = 14 To Cells(1, Columns.Count).End(xlToLeft).Column 'change 1 if data starts in a different row Range(Cells(1, c), Cells(Rows.Count, c).End(xlUp)).Copy Range("A" & Rows.Count).End(xlUp)(2) Next c Application.screenupdating=true End Sub 

Answer 3

特别是对于大量的数据，通过将原始数据读入VBAarrays，通常会更好（更快的执行时间） 操纵它; 然后将其写回工作表，与对工作表的多次读取/写入进行比较。

如果我正确理解你的数据设置（包括N2 ，没有空格，所有列长度相同）的连续范围的数据，下面是一个在你的数据上使用这种稍微不同的技术的例子。 如果我对数据设置的理解不正确，可能需要对代码进行较小的更改

此外，这可能不适用于32位Excel，但值得一试。

 Option Explicit Sub ManyIntoOneColumn() Dim WS As Worksheet Dim rWhatIHave As Range Dim rWhatIWant As Range Dim V As Variant, W As Variant Dim I As Long, J As Long, K As Long 'set worksheet Set WS = Worksheets("sheet1") 'change worksheet name 'set range to copy. If not contiguous, might have to do it differently Set rWhatIHave = WS.Range("N2").CurrentRegion 'set first cell of WhatIWant Set rWhatIWant = WS.Range("H2") 'read range into variant array V = rWhatIHave 'dimension results array ReDim W(1 To UBound(V, 1) * UBound(V, 2), 1 To 1) 'populate W K = 0 For I = 1 To UBound(V, 2) For J = 1 To UBound(V, 1) K = K + 1 W(K, 1) = V(J, I) Next J Next I 'set rWhatIWant Set rWhatIWant = rWhatIWant.Resize(rowsize:=UBound(W, 1), columnsize:=1) 'clear results range and write the values With rWhatIWant .EntireColumn.Clear .Value = W .EntireColumn.AutoFit End With End Sub 

Answer 4

它看起来像这样：

 Option Explicit Sub MoveData() Dim i As Long, lRowData As Long, lRowInput As Long ' "H" is 8th column, so you might want ' to change starting value of i to 9 or something like that For i = 14 To 14000 ' Last row in "H" column (where you paste data) lRowInput = Range("H" & ActiveSheet.Rows.Count).End(xlUp).Row ' Last row in i column (from where you draw data) lRowData = Cells(ActiveSheet.Rows.Count, i).End(xlUp).Row ' Copy values from i column to "H" column Range("H" & lRowInput + 1, "H" & lRowInput + lRowData - 1) = _ Range(Cells(2, i), Cells(lRowData, i)).Value Next i End Sub