需要对齐数据并消除空白

Question

我有一个从L列到AA列的数据集。我希望所有单元格都移动，以便每行中的最后一个单元格移动到第 AA 列，其余单元格向右移动，以便所有空白单元格都消失。有人可以协助VBA代码吗？谢谢！

Option Explicit
Sub main()
Dim rng As Range, cell As Range
Dim lastCol As Long, maxCol As Long, iCol As Long
With Worksheets("Align") '<--| change "Align" to your actual sheet name
Set rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants) '<--| get all columns "A" not empty cells
ReDim lastCols(1 To rng.Count) As Long '<--| resize last column index array accordingly to the number of not empty cells
For Each cell In rng '<--| loop through column "A" not empty cells
iCol = iCol + 1 '<--| update last column index array index
lastCols(iCol) = .Cells(cell.row, .Columns.Count).End(xlToLeft).Column '<--| update last column index array current index value
If lastCols(iCol) > maxCol Then maxCol = lastCols(iCol) '<--| update maximum column index
Next cell
iCol = 1 '<--| initialize last column index array index
For Each cell In rng '<--| loop through column "A" not empty cells
If lastCols(iCol) < maxCol And lastCols(iCol) > 3 Then cell.Offset(, lastCols(iCol) - 3).Resize(, maxCol - lastCols(iCol)).Insert xlShiftToRight '<--| if current cell row has at least three not empty cells and the last one has smaller column index than maximum column index then shift current cell row last three cells to align left with maximum column index
iCol = iCol + 1
Next cell
End With
End Sub

Answer 1

尝试这样的事情：

Sub main()
Dim rw As Range, arr, arr2(), i, n, num
Set rw = Worksheets("Align").Range("L2:AA2")
num = rw.Cells.Count
'run until row is empty
Do While Application.CountA(rw) > 0
arr = rw.Value                '<< pick up the row contents
ReDim arr2(1 To 1, 1 To num)  '<< new array for consolidated values
n = num
For i = num To 1 Step -1      '<< loop backwards
If Len(arr(1, i)) > 0 Then
arr2(1, n) = arr(1, i)
n = n - 1
End If
Next i
With rw
.HorizontalAlignment = xlCenter   '<< added
.NumberFormat = "@"               '<< added
.Value = arr2                     '<< re-populate the row
End With
Set rw = rw.Offset(1, 0)      '<< next row
Loop
End Sub