移动非空白单元格o下一个左空单元格直到单元格为Arrang VBA

Question

您好我目前在安排一组数字时遇到问题，其中我将排列单元格列，直到所有非空白单元格位于工作表的最左侧部分。目前我有这段代码：

Sub Sample()
     Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
Application.ScreenUpdating = False

    Dim count As Integer
    Dim row As Integer
    Dim repeat As Integer
    Dim first As Integer

    count = 3000
    row = 2
    ActiveSheet.Range("A1") = "phone1"
    For repeat = 1 To 4
    For first = 1 To count


    If ActiveSheet.Range("A" & row) = vbNullString Then
        ActiveSheet.Range("B" & row & ":E" & row).Cut Destination:=Range("A" & row)

        Else
         End If
         If ActiveSheet.Range("B" & row) = vbNullString Then
        ActiveSheet.Range("C" & row & ":E" & row).Cut Destination:=Range("B" & row)
        Else
         End If
          If ActiveSheet.Range("C" & row) = vbNullString Then
        ActiveSheet.Range("D" & row & ":E" & row).Cut Destination:=Range("C" & row)
        Else
         End If
          If ActiveSheet.Range("D" & row) = vbNullString Then
       ActiveSheet.Range("E" & row).Cut Destination:=Range("D" & row)
        Else
         End If

        row = row + 1
        Next first
        Next repeat
        Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

它有效，但速度很慢。并导致很多时间特别完成我使用300行。还有另一种方法可以做到这一点。 ？谢谢

Answer 1

使用.SpecialCells（xlCellTypeBlanks）查找空白，并将其向左移动删除。

Option Explicit

Sub wqew()
    Dim rw As Long, lr As Long, lc As Long, delrng As Range
    With Worksheets("Sheet1")
        lr = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                MatchCase:=False, SearchFormat:=False).Row
        lc = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
                MatchCase:=False, SearchFormat:=False).Column
        With .Range(.Cells(1, 1), .Cells(lr, lc))
            For rw = 1 To .Rows.Count
                Set delrng = .Rows(rw).Cells.SpecialCells(xlCellTypeBlanks)
                If Not delrng Is Nothing Then
                    delrng.Delete Shift:=xlToLeft
                End If
            Next rw
        End With
    End With
End Sub