excel - 从工作表中删除大量行时窒息

Question

我有一个子程序，它将表中的列添加到数组（strArr），循环遍历数组以确定要删除的行，并将我要删除的行添加到另一个数组（deleteArr）。然后我以相反的顺序循环以删除该行。它似乎适用于少数行，但完全挂在我在 deleteArr 中有几千个匹配项的行上，即使我让它永远运行。有谁知道这里发生了什么？

Public Sub DeleteRows(ByVal surveyString As String)

    Dim surveyArr() As String
    Dim retireArr() As String
    Dim strArr() As Variant
    Dim deleteArr() As Variant
    Dim totalRows As Long
    Dim tRange As String
    Dim x As Long
    Dim y As Long
    Dim ws As Worksheet

    'Split up fields to delete received from listBox
    If surveyString <> "" Then
        surveyArr = Split(surveyString, "|")
    End If

    totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
    tRange = "L2:L" & CStr(totalRows)
    strArr = Sheets("Employee").Range(tRange).Value
    x = 0

    If surveyString <> "" Then
        'determine which rows match and need to be deleted
        'the value in deleteArr is the row to delete
        For i = 1 To UBound(strArr)
            For i2 = 0 To UBound(surveyArr)
                If strArr(i, 1) = surveyArr(i2) Then
                    'resize the array and add the row value of what we want to delete
                    ReDim Preserve deleteArr(0 To x)
                    deleteArr(x) = i + 1
                    x = x + 1
                End If
            Next i2
        Next i
        'delete the row in reverse order so no rows are skipped
        Set ws = Sheets("Employee")
        y = UBound(deleteArr)
        For i = totalRows To 2 Step -1
            If i = deleteArr(y) Then
                ws.Rows(i).EntireRow.Delete
                If y > 0 Then
                    y = y - 1
                End If
            End If
        Next i
    End If

End Sub

Answer 1

您可以尝试合并要删除的所有行的范围，然后一次性删除。代码未经测试，希望这会为您指明正确的方向。

Public Sub DeleteRows(ByVal surveyString As String)

    Dim surveyArr() As String
    Dim retireArr() As String
    Dim strArr() As Variant
    Dim deleteArr() As Variant
    Dim totalRows As Long
    Dim tRange As String
    Dim x As Long
    Dim y As Long
    Dim ws As Worksheet
    Dim UnionRange As Range

    'Split up fields to delete received from listBox
    If surveyString <> "" Then
        surveyArr = Split(surveyString, "|")
    End If

    totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
    tRange = "L2:L" & CStr(totalRows)
    strArr = Sheets("Employee").Range(tRange).Value
    Set ws = Sheets("Employee")

    If surveyString <> "" Then
        'determine which rows match and need to be deleted
        'the value in deleteArr is the row to delete
        For i = 1 To UBound(strArr)
            For i2 = 0 To UBound(surveyArr)
                If strArr(i, 1) = surveyArr(i2) Then
                    If UnionRange Is Nothing Then
                        Set UnionRange = ws.Rows(i)
                    Else
                        Set UnionRange = Union(UnionRange, ws.Rows(i))
                    End If
                End if
            Next
        Next

        If Not UnionRange Is Nothing Then UnionRange.EntireRow.Delete

    End If

End Sub