问需要对齐数据并消除空白

EN

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