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

Question

I'm pretty new and would greatly appreciate your help. I have data in 14000 columns that are about 30 lines each.

I need to paste each column underneath one another such that I will only have 1 column remaining. I have provided an example screenshot:

My attempt at the VBA code is as follows (which doesn't work):

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

Please Help. Thanks

Answer 1

Try this, which assumes your data start in row 1.

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 2

It will look something like this:

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

Answer 3

Especially for large amounts of data, you will often be better off (faster execution time), by reading the original data into a VBA Array; manipulating it; then writing it back to the worksheet, as compared with multiple read/writes to the worksheet.

Here is an example of using that somewhat different technique on your data, if I understand your data setup correctly (a contiguous range of data including N2 , with no blanks, and all columns the same length). If my understanding of your data setup is incorrect, probably minor changes to the code will be necessary

Also, this might not work in 32 bit Excel, but it is worth a try.

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

Instead of copying range you can just assign the values to range as

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