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

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.

Answer 1

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

Answer 2

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

Answer 3

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