Speed Up VBA

[VbaHell]

Hello All

The code below looks in column "A" for a match "27009" and also "27003" it then copies these rows to sheet2 and then deletes the existing rows. Is there a way please to speed this up as there are thousands of records each day and at the moment this is slow

Sub Proforma()
Dim LR As Integer

Application.ScreenUpdating = False

LR = Range("A" & Rows.Count).End(xlUp).Row

Dim c As Range

For i = LR To 2 Step -1
Select Case Cells(i, 1)
Case "27009", "27003"
Cells(i, 1).EntireRow.Copy Sheets("Output").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Cells(i, 1).EntireRow.Delete
End Select
Next

Application.ScreenUpdating = True

End Sub

 

[Andrew Poulsom]

I imagine that AutoFilter will be quicker.

 

[dmt32]

setting calculation to manual would probably help but have a look at Rons site Delete row if a specific value exist (VBA)
He has some good examples using Union that may just work for you.

Dave

 

[mirabeau]

Hello All

The code below looks in column "A" for a match "27009" and also "27003" it then copies these rows to sheet2 and then deletes the existing rows. Is there a way please to speed this up as there are thousands of records each day and at the moment this is slow

...

End Sub

You might try this code, which is probably fast enough for you. Note though that this one only transfers values and not formats.

If you want formats to be transferred as well as values at about the same speed, please post back.

Sub delrowsfaster()
Dim n&, m&, k&, l&
Dim a(), b()
Dim i&, j&
n = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
m = Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
a = Range("A1").Resize(n, m)
ReDim b(1 To n, 1 To m), c(1 To n, 1 To m)
For i = 2 To n
    If a(i, 1) = "27009" Or a(i, 1) = "27003" Then
        k = k + 1
        For j = 1 To m
            b(k, j) = a(i, j)
        Next j
    Else
        l = l + 1
        For j = 1 To m
            c(l, j) = a(i, j)
        Next j
    End If
Next i
Range("A2").Resize(n, m).ClearContents
Range("A2").Resize(k + 1, m) = c
With Sheets("output")
    .Cells(Rows.Count, 1).End(3).Offset(1).Resize(l, m) = b
End With
End Sub

 

[Peter_SSs]

My attempt

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> CopyAndDelete()<br>  Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>  <SPAN style="color:#00007F">With</SPAN> ActiveSheet.UsedRange<br>    .AutoFilter Field:=1, Criteria1:="=27003", Operator:=xlOr, Criteria2:="=27009"<br>    .Offset(1).Copy Destination:=Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1)<br>    .Offset(1).ClearContents<br>    .AutoFilter<br>    .Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _<br>      MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal<br>  <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>  Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[VbaHell]

dmt32

Your link to Ron's site really helped
Many thanks

 

[VbaHell]

Mirabeau

Nice piece of code and it works really quickly
Thank you very much

 

[VbaHell]

Hi peter

Your code is bugging out on this line [.Offset(1).Copy Destination:=Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1)]

Run Time Error 1004 (Application defined or Object defined error)

Any ideas please

 

[Peter_SSs]

Hi peter

Your code is bugging out on this line [.Offset(1).Copy Destination:=Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1)]

Run Time Error 1004 (Application defined or Object defined error)

Any ideas please

I have not been able to reproduce that problem so I am not sure what is causing it for you. You could try adding the blue bits in my code.

Sub CopyAndDelete()
  Application.ScreenUpdating = False
  With ActiveSheet.UsedRange
    .AutoFilter Field:=1, Criteria1:="=27003", Operator:=xlOr, Criteria2:="=27009"
    .Offset(1).Resize(.Rows.Count - 1).Copy Destination:=Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1)
    .Offset(1).Resize(.Rows.Count - 1).ClearContents
    .AutoFilter
    .Sort Key1:=Cells(2, .Columns.Count + 1), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
      MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
  End With
  Application.ScreenUpdating = True
End Sub

One thing I forgot to mention is that my code re-orders the remaining original data and that may not suit you.


The other thing I noticed, not sure why it is happening or if I've mis-read the question, is that I tested mirabeau's code on 100,000 rows and 2 columns of data (no blanks) and the original sheet ended up with 6,645 rows and the Output sheet ended up with 19,930 rows so I don't know what happened to the other 73,425 rows.

 

[VbaHell]

Hi Peter

I deleted the sort function and it now works
Really quick and such a small piece of code
Thanks a lot


Sub CopyAndDelete()
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
.AutoFilter Field:=1, Criteria1:="=27003", Operator:=xlOr, Criteria2:="=27009"
.Offset(1).Resize(.Rows.Count - 1).Copy Destination:=Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Offset(1).Resize(.Rows.Count - 1).ClearContents
.AutoFilter


End With
Application.ScreenUpdating = True
End Sub