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

您好我目前有一个问题，安排一组数字，其中我会安排细胞列，直到所有非空白单元格在工作表的最左侧部分。 目前我有这样的代码：

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