How can I modify my code so that it runs quicker?

Question

I work a cumulative report that grows daily up to about 150,000 rows of data. I am trying to run a macro that will move the data from one defined sheet to another defined sheet. Unfortunately, it is taking an extremely long time and leaves my Excel window frozen.

I have been staring at this code trying to make it work for our needs for so long that I haven't tried anything different.

Sub Move()
Application.ScreenUpdating = False

Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
lastrow = Worksheets("From TaxWise").UsedRange.Rows.Count
lastrow2 = Worksheets("State").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
    For r = lastrow To 2 Step -1
        If Not Range("L" & r).Value = "US" Then
            Rows(r).Cut Destination:=Worksheets("State").Range("A" & lastrow2 + 1)
            lastrow2 = lastrow2 + 1
            Else:
        End If
Next r

On Error Resume Next
ActiveWorkbook.Worksheets("From TaxWise").Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

Application.ScreenUpdating = True
End Sub

Not sure what I need to adjust as I feel my current code is running through 150,000 records line by line to identify, cut and move.

Instead of looping through records, why not just filter for values not equal to US? You can then move all filtered values to a new sheet in one go. — BigBen, Jan 18 '19 at 18:44
[Here](https://stackoverflow.com/questions/17531128/copy-paste-calculate-visible-cells-from-one-column-of-a-filtered-table) is an example of how to implement the great suggestion by @BigBen — urdearboy, Jan 18 '19 at 20:08
Here's a good discussion on this topic. https://stackoverflow.com/questions/30959315/excel-vba-performance-1-million-rows-delete-rows-containing-a-value-in-less/30959316 — Ryan Wildry, Jan 18 '19 at 21:38

score 3 · Answer 1 · answered Jan 18 '19 at 19:23

You can filter and work with visible cells or you can avoid deleting rows inside your loop.

Say, for instance, that you have 500 cells that are not equal to US. You will then have 500 instances of copy/paste & deletions. This is highly inneficient.

Instead, add your target cells to a Union (collection of cells) and then outside of the loop, perform your operations on the collection. No matter how many rows are being targeted, you will have just one instance of copy, one instance of paste, and one instance of deletion.

Sub Moving()

Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("From TaxWise")
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("State")
Dim MoveMe As Range, myCell As Range, LR2 As Long

Dim LR As Long: LR = cs.Range("L" & cs.Rows.Count).End(xlUp).Row

For Each myCell In cs.Range("L2:L" & LR)
    If myCell <> "US" Then
        If Not MoveMe Is Nothing Then
            Set MoveMe = Union(MoveMe, myCell)
        Else
            Set MoveMe = myCell
        End If
    End If
Next myCell

If Not MoveMe Is Nothing Then
    LR2 = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
        MoveMe.EntireRow.Copy
        ps.Range("A" & LR2).PasteSpecial xlPasteValues
    MoveMe.EntireRow.Delete
End If

End Sub

Thank you for your input! Unfortunately, I am running this code through about 65,000 records and it takes just as long to process. I am still trying to figure out why because based on your logic, running this code should have been much quicker than my original work. — AdamJ, Jan 18 '19 at 19:55
You may need to toggle off calculations. Also, you should check the value of `LR`. Maybe your book has extended the used range due to cells with null values. Also, deleting non-continuous ranges is usually a slow process. You can add time stamps in the macro to see what part is taking up the time. Its likely the delete line. You can sort `Column L` to quicken this process since the rows will be grouped together — urdearboy, Jan 18 '19 at 19:57

Ron Rosenfeld · Accepted Answer · 2019-01-19T07:18:50.463

This code took about two seconds to run on 150000 records with about 3000 equal to US.

You'll need to alter it to match your setup. eg: Names of the various worksheets; cell ranges in case your tables don't start at A1, slightly different syntax if your data is in Excel Tables rather than just ranges, etc

It uses Excel's built-in autofilter

The destination sheet has all of the lines except for those with US.

Option Explicit
Sub noUS()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rSrc As Range, rDest As Range
    Const filterColumn As Long = 4 'Change to 12 for column L
    Dim LRC() As Long

Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
    Set rDest = wsDest.Cells(1, 1)
    wsDest.Cells.Clear

With wsSrc
'get last row and column of the source worksheet
    LRC = LastRowCol(.Name)

'set the range
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))

'set the filter
  'first turn it off
  .AutoFilterMode = False

  'now set it for the range
  rSrc.AutoFilter _
    field:=filterColumn, _
    Criteria1:="<>US", _
    visibledropdown:=False

  End With

  Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
  rSrc.Copy rDest

  'turn off the autofilter
  wsSrc.AutoFilterMode = False
End Sub

'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function

And if you want to have a separate sheet with the US rows, you can insert the following before the end of the Sub:

'now get the US rows
With wsSrc
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
    .AutoFilterMode = False

    rSrc.AutoFilter _
        field:=filterColumn, _
        Criteria1:="US", _
        visibledropdown:=False

    Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
    rSrc.Copy rUS
    .AutoFilterMode = False
End With

I prefer to maintain the original data, rather than deleting stuff from the source. But, if you like, after you've done the above, and you are happy with the result, merely delete wsSrc

Edit

The above code modified so you wind up with, what I think you want, which is worksheets("State") containing all of the non-US items; and worksheets("From TaxWise") containing all of the US items.

Instead of deleting non-contiguous rows, a very slow process, we filter the rows we want to a new worksheet; delete the original worksheet, and rename the new sheet.

Don't try this at home without a backup of your original data.

Option Explicit
Sub noUS()
    Dim wsSrc As Worksheet, wsDest As Worksheet, wsUS As Worksheet
    Dim rSrc As Range, rDest As Range, rUS As Range
    Const filterColumn As Long = 12
    Dim LRC() As Long

Set wsSrc = Worksheets("From TaxWise")
Set wsDest = Worksheets("State")
    Set rDest = wsDest.Cells(1, 1)
    wsDest.Cells.Clear

With wsSrc
'get last row and column of the source worksheet
    LRC = LastRowCol(.Name)

'set the range
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))

'set the filter
  'first turn it off
  .AutoFilterMode = False

  'now set it for the range
  rSrc.AutoFilter _
    field:=filterColumn, _
    Criteria1:="<>US", _
    visibledropdown:=False

  End With

  Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
  rSrc.Copy rDest

  'turn off the autofilter
  wsSrc.AutoFilterMode = False

  'now get the US rows, may need to add worksheet
On Error Resume Next
Set wsUS = Worksheets("US")
    If Err.Number = 9 Then
        Worksheets.Add
        ActiveSheet.Name = "US"
    End If
Set wsUS = Worksheets("US")
    Set rUS = wsUS.Cells(1, 1)

With wsSrc
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
    .AutoFilterMode = False

    rSrc.AutoFilter _
        field:=filterColumn, _
        Criteria1:="US", _
        visibledropdown:=False

    Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
    rSrc.Copy rUS
    .AutoFilterMode = False
End With

'Delete Taxwise and rename US sheets
Application.DisplayAlerts = False
wsSrc.Delete
wsUS.Name = "From TaxWise"
Application.DisplayAlerts = True

End Sub

'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function

@urdearboy Some of the excel native methods are quite efficient. And, in general, processing worksheet rows within VBA (reads, writes, deletes) can be pretty slow. — Ron Rosenfeld, Jan 18 '19 at 21:43
This worked very quickly, however, all the non "US" records need to be deleted from the source worksheet "From TaxWise". I believe this is what is taking up the most time as urdearboy stated in his example above. Am I missing the code to delete those records on the source worksheet? — AdamJ, Jan 18 '19 at 22:30
@AdamJ Did you try `rSrc.delete`? Or maybe `rSrc.EntireRow.Delete`? Or use the filter technique to copy the US rows to a new worksheet and delete the first. Then rename. See which is faster. — Ron Rosenfeld, Jan 19 '19 at 01:47
@AdamJ See my edit for the new worksheet/rename method with seems to be the fastest. — Ron Rosenfeld, Jan 19 '19 at 07:19
Works at the speed of light! Thank you for your guidance and edit! I will remember this in the future when manipulating so much data. — AdamJ, Jan 21 '19 at 14:50

score 0 · Answer 3 · answered Jan 18 '19 at 19:26

0

Move Rows

Union Version

Option Explicit

Sub Move()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Dim rngU As Range, r As Long, lastrow2 As Long, lastrow As Long

    On Error GoTo ProcedureExit

    With Worksheets("From Taxwise")
        lastrow = .Cells(.Rows.Count, "L").End(xlUp).row
        For r = 2 To lastrow
            If Not .Range("L" & r).Value = "US" Then
                If Not rngU Is Nothing Then
                    Set rngU = Union(rngU, .Cells(r, 1))
                  Else
                    Set rngU = .Cells(r, 1)
                End If
            End If
        Next
    End With

    If Not rngU Is Nothing Then
        With Worksheets("State")
            lastrow2 = .Cells(.Rows.Count, "L").End(xlUp).row
            rngU.EntireRow.Copy .Range("A" & lastrow2 + 1)
            rngU.EntireRow.Delete
        End With
        Set rngU = Nothing
    End If

ProcedureExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

answered Jan 18 '19 at 19:26

VBasic2008

44,888
5
17
28

2

You do not need to use `Set rngU = Nothing` https://stackoverflow.com/a/51066727/6706419 – urdearboy Jan 18 '19 at 19:30
Thank you for your input! Unfortunately, I am running this code through about 65,000 records and it takes just as long to process. I am still trying to figure out why because based on your logic, running this code should have been much quicker than my original work. – AdamJ Jan 18 '19 at 19:55
@AdamJ: Thanks for pointing this out, because it ran suspiciously slow on the 500 rows I had in my example workbook. I'm usually using it just to delete rows, which is very fast. I guess we'll have to figure out some other solution. – VBasic2008 Jan 18 '19 at 20:00
Gotcha! Thanks - I'll keep on pushing through! – AdamJ Jan 18 '19 at 20:03
@AdamJ: An array version might be the solution, where another element to speed up would be to reduce the number of columns by calculating the 'Last Column'. – VBasic2008 Jan 18 '19 at 20:11
I see where you are coming from. I will try and update. – AdamJ Jan 18 '19 at 21:46

How can I modify my code so that it runs quicker?

3 Answers3

Edit

Move Rows

Union Version