Choking when delete large # of rows from a sheet - excel

Question

I have a sub which adds a column from a table to an array (strArr), loops through the array to determine which rows to delete, and adds the row I want to delete to another array (deleteArr). I then loop in reverse order to delete the row. It seems to work fine for a small number of rows, but completely hangs on rows where I have a few thousand matches in deleteArr, even if I let it run forever. Does anyone have an idea what is going on here?
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

You could try to union a range of all rows you want to delete, then delete in one shot. Code is untested, hopefully this points you in the right direction.
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