Удушье при удалении большого количества строк с листа

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