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

需要对齐数据并消除空白

1 个答案: