Code Optimisation (Find and Delete)

[applebyd]

Good Morning all....

Got an odd one in that what I have is working, just not well....

I have a sheet with two columns and 100k plus records

Col A contains a text description that is fetched by a VBA Cut and Paste from another sheet.

In ColB I have automated a COUNTIF to copy from Row2 down to a variable called ENDROW.
This then calculates the COUNTIF, copies the data, pastes back as values and sorts first on ColB then ColA.

What I need to do is remove all rows where ColB >=2

I have the below, which works, but, it is VERY VERY slow.
<I>
Sub Delete_Extra_Rows()

Sheets("Lists").Select

Application.Calculation = xlCalculationManual

Set WS = ActiveSheet

For i = Cells.SpecialCells(xlLastCell).Row To 1 Step -1

If WS.Cells(i, 1).Value > 1 Then WS.Cells(i, 1).EntireRow.Delete


Next i

Application.Calculation = xlCalculationAutomatic

END SUB

</I>

Does anyone have any ideas how this could be improved, or, am I stuck with the time?

Any help appreciated.

Regards

DaveA

 

[FormR]

Hi, is this any quicker..

Sub Delete_Extra_Rows()
Application.Calculation = xlCalculationManual
With Sheets("List").Range("A1").CurrentRegion
    .AutoFilter Field:=2, Criteria1:=">=2", Operator:=xlAnd
    .Offset(1).SpecialCells(xlVisible).EntireRow.Delete
    .AutoFilter
End With
Application.Calculation = xlCalculationAutomatic
End Sub

 

[applebyd]

Hi, is this any quicker..

Sub Delete_Extra_Rows()
Application.Calculation = xlCalculationManual
With Sheets("List").Range("A1").CurrentRegion
    .AutoFilter Field:=2, Criteria1:=">=2", Operator:=xlAnd
    .Offset(1).SpecialCells(xlVisible).EntireRow.Delete
    .AutoFilter
End With
Application.Calculation = xlCalculationAutomatic
End Sub

Thanks.....

It's giving me a Subscript out of range error (9) here:

With Sheets("List").Range("A1").CurrentRegion

Any ideas?

But many thanks for the speed of the response.

Regards

DaveA

 

[FormR]

It's giving me a Subscript out of range error (9) here:

With Sheets("List").Range("A1").CurrentRegion

Hi, sorry, try to change "List" to "Lists" - this should be the name of the sheet that contains your data.

 

[tonyyy]

DaveA,

So I didn't fully understand your description but I think I understood your code. Typically working with arrays will be faster than ranges and cells; you might consider the following...

Sub DeleteRows_1027867()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim ws As Worksheet
Dim arr1 As Variant, arr2 As Variant
Dim i As Long, j As Long
Dim rng As Range

Set ws = Sheets("Lists")
Set rng = ws.Range("A2:B" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
arr1 = rng
ReDim arr2(1 To rng.Rows.Count, 1 To 2)
j = 1

For i = LBound(arr1) To UBound(arr1)
    If arr1(i, 1) <= 1 Then
        arr2(j, 1) = arr1(i, 1)
        arr2(j, 2) = arr1(i, 2)
        j = j + 1
    End If
Next i

rng.Value = arr2
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

Cheers,

tonyyy

 

[applebyd]

Hi, sorry, try to change "List" to "Lists" - this should be the name of the sheet that contains your data.

AARGHHH.......

I *SHOULD* have spotted that!

Thanks, two different approaches, both blisteringly fast.

Learned a lot from this!

Again, thanks both

Regards

DaveA

 

[tonyyy]

Just pointing out, the description in your original post states...

What I need to do is remove all rows where ColB >=2

...which is different than this line in your code...

[I]If WS.Cells(i, 1).Value > 1 Then WS.Cells(i, 1).EntireRow.Delete[/I]

And since you said your code works, that's why I chose to follow your code rather than your description.

Oh, and you're very welcome.