删除具有一个特定列的空白行

我做了一个代码，将在我的表（table1）的所有行中search，并在某一列中find一个空白的单元格，该行将复制另一个表（表2），并从table1擦除。 当我把代码运行vb保持“不运行”，我需要强制停止，但是当我在Excel中查看表，我看到他复制一些行（不删除，因为我强制停止之前，他到达那里）。 我在一个有95k行的桌子上做这个，花了很多时间，我需要那么快。 所以这是代码：

Function DeleteRows() Debug.Print Time Dim shtSrc As Worksheet, shtDest As Worksheet Dim lRow As Long, Row As Long Dim rw As Range, rngDel As Range Application.ScreenUpdating = False viewmode = ActiveWindow.View ActiveWindow.View = xlNormalView Application.EnableEvents = False Application.DisplayStatusBar = False ActiveSheet.DisplayPageBreaks = False Row = 2 lRow = Range("A" & Rows.Count).End(xlUp).Row Set shtSrc = Worksheets("Sheet3") Set shtDest = Worksheets("Sheet2") shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1") For i = 2 To lRow Set rw = shtSrc.Rows(i) If (rw.Cells(42).Value = "") Then rw.Copy shtDest.Rows(Row) AddToRange rngDel, rw Row = Row + 1 End If Next i If Not rngDel Is Nothing Then rngDel.Delete End If Application.DisplayStatusBar = True ActiveWindow.View = viewmode Application.ScreenUpdating = False Debug.Print Time End Function 'utility sub for building up a range Sub AddToRange(rngTot, rng) If rngTot Is Nothing Then Set rngTot = rng Else Set rngTot = Application.Union(rng, rngTot) End If End Sub 

Answer 1

自动filter是一个更快的方式去做这个比迭代，我运行下面的代码在100,000行与42个字段在2秒。 最后有两张新的纸张，其中一张带着你移动的行（第42列中的空白值），另一张带着你保留的行，你的原始纸张保持不动。

 Const SourceSheetName As String = "Sheet3" Const ColumnToCheckForBlanks As Long = 42 Dim shtSrc As Worksheet Sub sortanddelete() On Error GoTo errorhandler Debug.Print "START-->"; Now() Set shtSrc = Sheets(SourceSheetName) Application.DisplayAlerts = False Application.Calculation = xlCalculationManual FilterAndCopy shtSrc, "Deleted Rows", "=" FilterAndCopy shtSrc, "Kept Rows", "<>" GoTo cleanup errorhandler: MsgBox Err.Number & "-->" & Err.Description, vbCritical, "Error" cleanup: Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Debug.Print "END -->" & Now() End Sub Sub FilterAndCopy(shtSrc As Worksheet, destSheetName As String, Criteria As String) Dim DestSheet As Worksheet DelIfSheetExists destSheetName shtSrc.UsedRange.AutoFilter Field:=ColumnToCheckForBlanks, Criteria1:=Criteria shtSrc.UsedRange.Copy Set DestSheet = Sheets.Add(After:=shtSrc) DestSheet.Name = destSheetName DestSheet.Paste End Sub Sub DelIfSheetExists(SheetName As String) On Error GoTo errorhandler Worksheets(SheetName).Delete Exit Sub errorhandler: Err.Clear End Sub 

结果：

 START-->06/11/2015 9:13:13 AM END -->06/11/2015 9:13:15 AM