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

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

我没有使用VBA的经验，但是已经logging了一个手动执行此操作的macros，而且这个macros正在持续。 请帮助我设置一些东西，去喝咖啡，然后回来看看所做的工作。 （注：有些列有1个字/行…这使得我的macros每次遇到这些错误时都会抛出一个错误）。

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

Answer 1

如果你想让所有的单元格在一列中alignment，你可以使用下面的代码：

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

如果你进入你的录制的macros，并在顶部插入这一行：

 Application.ScreenUpdating = False 

然后在代码的底部将screenUpdating设置为true。 这应该会大大加速代码，因为它会阻止macros在每次更改后直观地显示更改。 这样可以避免许多对graphics的调用，从而减慢速度。

Answer 4

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

 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