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

Question

我做了一个代码，它将在我的表（table1）的所有行中搜索，并且当某个列中找到一个空白单元格时，该行将被复制到另一个表格（table2）并被擦除来自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

自动筛选去这比迭代更快的方式，我跑了下面的代码在100,000行以2秒42场。您最终会得到两张新纸张，其中一张带有您移动的行（第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