刪除具有一個特定列的行的空白

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