如果您希望所有单元格对齐在一列中,可以使用以下代码:
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