Question

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

我没有使用VBA的经验，但是已经录制了一个宏来手动执行此操作并且它将永远消失。请帮助我可以设置的东西然后去喝咖啡然后回来看看完成的工作。（注意：有些列有1个单词/行...这使得我的宏在每次遇到其中一个时都会抛出错误。）

谢谢！希望有人能提供帮助。 -Mike

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 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 3

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

Application.ScreenUpdating = False

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

Answer 4

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

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

将多列转换为一个大列（Excel 2010）

4 个答案: