vba 将多列转换为一个大列 (Excel 2010)

Convert Multiple Columns to One Large Column (Excel 2010)

提问by MikeM

I would like to convert 15,096 columns of text (one word per cell) to one large column including every cell from the original columns. My original columns vary in size (i.e. one column may have 4 cells/rows, while another may have 100 cells/rows).

我想将 15,096 列文本（每个单元格一个单词）转换为一个大列，包括原始列中的每个单元格。我的原始列的大小不同（即一列可能有 4 个单元格/行，而另一列可能有 100 个单元格/行）。

I have no experience with VBA, but have recorded a macro to do this somewhat manually and it is taking forever. Please help with something that I could set and go get coffee and come back to see the job done. (NOTE: Some columns have 1 word/row...this has made my macro throw an error every time it encounters one of these).

我没有使用 VBA 的经验，但是已经录制了一个宏来手动执行此操作，并且需要花费很长时间。请帮忙做一些我可以设置的事情，然后去喝咖啡，然后回来看看工作完成了。（注意：有些列有 1 个字/行……这使我的宏每次遇到其中一个时都会抛出错误）。

Thank you! Hope someone can help. -Mike

谢谢！希望有人能帮忙。-麦克风

回答by nutsch

If you want all your cells aligned in one column, you can use this code:

如果您希望将所有单元格对齐在一列中，您可以使用以下代码：

Sub ToArrayAndBack()
Dim arr As Variant, lLoop1 As Long, lLoop2 As Long
Dim arr2 As Variant, lIndex As Long

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


ReDim arr2(ActiveSheet.UsedRange.Cells.Count - ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Count)

arr = ActiveSheet.UsedRange.Value


For lLoop1 = LBound(arr, 1) To UBound(arr, 1)
    For lLoop2 = LBound(arr, 2) To UBound(arr, 2)
        If Len(Trim(arr(lLoop1, lLoop2))) > 0 Then
            arr2(lIndex) = arr(lLoop1, lLoop2)
            lIndex = lIndex + 1
        End If
    Next
Next

Sheets.Add
Range("A1").Resize(, lIndex + 1).Value = arr2

Range("A1").Resize(, lIndex + 1).Copy
Range("A2").Resize(lIndex + 1).PasteSpecial Transpose:=True
Rows(1).Delete

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

If you want to concatenate each row, use this instead. It will consolidate your cells in a new sheet.

如果要连接每一行，请改用它。它会将您的单元格合并到一个新工作表中。

Sub Consolidate()
Dim shtDest As Worksheet, shtOrg As Worksheet
Dim lLastRow As Long, lLastCol As Long, lLoop As Long
Dim sFormula  As String

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


Set shtOrg = ActiveSheet
lLastCol = shtOrg.UsedRange.Columns.Count
lLastRow = shtOrg.Cells(Rows.Count, 1).End(xlUp).Row

Set shtDest = Sheets.Add

For lLoop = 1 To lLastCol
    sFormula = sFormula & "'" & shtOrg.Name & "'!RC" & lLoop & ","
Next lLoop

sFormula = Left(sFormula, Len(sFormula) - 1)

shtDest.Range("A1:A" & lLastRow).FormulaR1C1 = "=concatenate(" & sFormula & ")"
shtDest.Range("A1:A" & lLastRow).Value = shtDest.Range("A1:A" & lLastRow).Value


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

or if you want your cells separated by spaces

或者如果你想用空格分隔你的单元格

Sub Consolidate()
Dim shtDest As Worksheet, shtOrg As Worksheet
Dim lLastRow As Long, lLastCol As Long, lLoop As Long
Dim sFormula  As String

Const sSeparator As String = " "

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


Set shtOrg = ActiveSheet
lLastCol = shtOrg.UsedRange.Columns.Count
lLastRow = shtOrg.Cells(Rows.Count, 1).End(xlUp).Row

Set shtDest = Sheets.Add

For lLoop = 1 To lLastCol
    sFormula = sFormula & "'" & shtOrg.Name & "'!RC" & lLoop & "&""" & sSeparator & ""","
Next lLoop

sFormula = Left(sFormula, Len(sFormula) - 1)

shtDest.Range("A1:A" & lLastRow).FormulaR1C1 = "=trim(concatenate(" & sFormula & "))"
shtDest.Range("A1:A" & lLastRow).Value = shtDest.Range("A1:A" & lLastRow).Value


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

回答by specialscope

Sub MultiColsToA() 
Dim rCell As Range 
Dim lRows As Long 
Dim lCols As Long 
Dim lCol As Long 
Dim ws As Worksheet 
Dim wsNew As Worksheet 

lCols = Columns.Count 
lRows = Rows.Count 
Set wsNew = Sheets.Add() 

For Each ws In Worksheets 
    With ws 
        For Each rCell In .Range("B1", .Cells(1, lCols).End(xlToLeft)) 
            .Range(rCell, .Cells(lRows, rCell.Column).End(xlUp)).Cut _ 
            wsNew.Cells(lRows, 1).End(xlUp)(2, 1) 
        Next rCell 
    End With 
Next ws 

End Sub 

回答by emschorsch

If you go into your recorded macro and insert this line at the top:

如果您进入录制的宏并在顶部插入此行：

Application.ScreenUpdating = False

Then set screenUpdating back to true at the bottom of your code. This should dramatically speed up the code as it prevents the macro from visually showing you the changes after every single change. This avoids many many calls to graphics, which slow it down.

然后在代码底部将 screenUpdating 设置回 true 。这应该会显着加快代码速度，因为它可以防止宏在每次更改后直观地向您显示更改。这避免了许多对图形的调用，这会减慢它的速度。

回答by Dick Kusleika

Here's another way. This joins all the strings in the row and puts the resulting string in the first cell of the row. That means that anything that was in that cell will be overwritten. Thatmeans that you should try this on a copy of your workbook because if it doesn't do what you want you will have lost data.

这是另一种方式。这将连接该行中的所有字符串并将结果字符串放入该行的第一个单元格中。这意味着该单元格中的任何内容都将被覆盖。 这意味着您应该在工作簿的副本上尝试此操作，因为如果它没有按照您的意愿运行，您将丢失数据。

Sub MakeOneColumn()

    Dim rRow As Range
    Dim vaRow As Variant
    Dim i As Long
    Dim aJoin() As Variant

    'Loop through each row in the sheet
    For Each rRow In Sheet1.UsedRange.Rows

        'put the rows values in an array
        vaRow = rRow.Value

        'Convert the array from 2-d to 1-d because the Join function needs 1-d
        ReDim aJoin(LBound(vaRow, 2) To UBound(vaRow, 2))
        For i = LBound(vaRow, 2) To UBound(vaRow, 2)
            aJoin(i) = vaRow(1, i)
        Next i

        'Join the array into one string, replace double spaces, and write to the
        'first cell in the row (replacing what was there - so be careful)
        rRow.Cells(1).Value = Replace(Join(aJoin, Space(1)), Space(2), Space(1))
    Next rRow

End Sub