UserForm taking too long to delete rows

Question

I have been developing a UserForm that uses a listbox populated by the A column to delete specific rows based on listbox selection. But when I click the "Apply" button it takes a ridiculously long time until it processed and deleted the rows.

The code for the Apply button is the following, there is almost no other code in the UserForm. Just Me.Hide in the Cancel button.

Private Sub CommandApply_Click()

Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range

' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
    If Me.ListBox1.Selected(i) Then
    Else
        col.Add i + 1
    End If
Next i

' Then delete the rows
Set rng = Worksheets("Sheet1").Range("A1:A100")
For Each itm In col
    rng.Rows(itm).EntireRow.Delete
Next itm

 blnCancel = False
   Me.Hide
End Sub

Answer 1

I think you'd be better off collecting the non-selected items into a Range in your loop and then just deleting that:

Private Sub CommandApply_Click()

Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range

' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
    If Not Me.ListBox1.Selected(i) Then
        If rng Is Nothing then 
           Set rng = Worksheets("Sheet1").Range("A" & i + 1)
        Else
           Set rng = Union(rng, Worksheets("Sheet1").Range("A" & i + 1))
        End If
    End If
Next i

' Then delete the rows
If not rng Is Nothing then rng.Entirerow.delete
 blnCancel = False
   Me.Hide
End Sub