excel - 将多列转换为一大列 (Excel 2010)

Question

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

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

谢谢！希望有人可以提供帮助。-麦克风

Answer 1

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

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

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

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

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

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

Answer 2

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

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

Answer 3

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 

Answer 4

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

Application.ScreenUpdating = False

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