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

自动过滤是一种比迭代更快的方法，我在2秒内在100,000行和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

删除一个特定列为空的行

1 个答案: