Improve Cut Paste to Another Sheet Based on Multiple values in cell

[NHagedorn]

Can anyone help me? This code works but it takes toooo long to run. Is there a way I can rework the de to speed it up?Thank you,Nate Sub MoveLS() Dim i As Variant Dim endrow As Integer Dim ASR As Worksheet, LS As Worksheet Set ASR = ActiveWorkbook.Sheets("Detailed Activity") Set LS = ActiveWorkbook.Sheets("Check These") endrow = ASR.Range("A" & ASR.Rows.Count).End(xlUp).Row For i = 2 To endrow If ASR.Cells(i, "M").value = "Cancelled - Duplicate Request" Or _ ASR.Cells(i, "M").value = "Cancelled - MD Elected Not to Proceed" Or _ ASR.Cells(i, "M").value = "Cancelled - Missing Information Not Received" Or _ ASR.Cells(i, "M").value = "EC Not Covered Complete" Or _ ASR.Cells(i, "M").value = "Missing Information" Or _ ASR.Cells(i, "M").value = "Not Covered Complete - Diagnosis not covered" Or _ ASR.Cells(i, "M").value = "Not Covered Complete - Other - Not Covered" Or _ ASR.Cells(i, "M").value = "Not Covered Complete - Policy term" Then ASR.Cells(i, "M").EntireRow.Cut Destination:=LS.Range("A" & LS.Rows.Count).End(xlUp).Offset(1) End If NextEnd Sub

 

[bobsan42]

Hi Nate.
First of - please post code properly to make it readable. If want more people to look into your post, that is:

Sub MoveLS()
    Dim i As Variant
    Dim endrow As Integer
    Dim ASR As Worksheet, LS As Worksheet
    Set ASR = ActiveWorkbook.Sheets("Detailed Activity")
    Set LS = ActiveWorkbook.Sheets("Check These")
    endrow = ASR.Range("A" & ASR.Rows.Count).End(xlUp).Row
    For i = 2 To endrow
        If ASR.Cells(i, "M").Value = "Cancelled - Duplicate Request" Or _
            ASR.Cells(i, "M").Value = "Cancelled - MD Elected Not to Proceed" Or _
            ASR.Cells(i, "M").Value = "Cancelled - Missing Information Not Received" Or _
            ASR.Cells(i, "M").Value = "EC Not Covered Complete" Or _
            ASR.Cells(i, "M").Value = "Missing Information" Or _
            ASR.Cells(i, "M").Value = "Not Covered Complete - Diagnosis not covered" Or _
            ASR.Cells(i, "M").Value = "Not Covered Complete - Other - Not Covered" Or _
            ASR.Cells(i, "M").Value = "Not Covered Complete - Policy term" Then
            ASR.Cells(i, "M").EntireRow.Cut Destination:=LS.Range("A" & LS.Rows.Count).End(xlUp).Offset(1)
        End If
    Next
[COLOR=#ff0000]i=null
set ASR = nothing
set LS = nothing[/COLOR]
End Sub

It is generally good practice to clear you variables upon completion, so I added the lines in red.

 

[bobsan42]

Now to the point. There are many things you can do to speed up your code:
Your code basically has two parts: data checking & data moving.
The checking part has less impact on the performance but over 100 000 rows of data I managed to reduce it from 3 838 ms to 166 ms.

1. The first thing that comes to mind is that you check for too many conditions - I would normally try to keep them down.
I suggest to combine all your strings in 1 and check if the cell value is part of this string
2. Checking cell value each time slows the process down because each time you have to get the value from the cell.
Assign the cell value to a variable once and then use the variable to check if the condition is met
3. Looping with integer like this is much slower then using For Each rng In ASR.Range("M2:M" & endrow)

The bigger performance impact comes from the data moving.
Over big tables it can take very long time.
1. If possible it is much faster to copy/paste block of data at once (several rows) rather than one at a time.

2. Disable Automatic calculation and Screen updating at the beginning of your procedure. And re-enable them at the end.


HTH

 

[NHagedorn]

Bobsan42,

Thank you for your assistance. However, I'm really not sure how or what that would look like. I'm sorry. I'm very new to VBA, and kind of understand what you are suggesting, but have no clue what that looks like or where I would put the code.

Could you possibly provide more assistance?

Number of Conditions... These are the one I need from the report. Don't think I can or don't know how to limit them.

Thank you again,
Nate

 

[bobsan42]

try this

Sub MoveLS()
    Application.Calculation = xlCalculationManual
    Dim j As Long
    Dim endrow As Long, varVal
    Dim ASR As Worksheet, LS As Worksheet
    Set ASR = ThisWorkbook.Worksheets("Detailed Activity")
    Set LS = ActiveWorkbook.Sheets("Check These")
    endrow = ASR.Range("A" & ASR.Rows.Count).End(xlUp).Row
    
    Dim rng As Range, rngLS As Range
    Set rngLS = LS.Range("A" & LS.Rows.Count).End(xlUp).Offset(1)

    For Each rng In ASR.Range("M2:M" & endrow)
        varVal = rng.Value
        If varVal = "Cancelled - Duplicate Request" Or _
            varVal = "Cancelled - MD Elected Not to Proceed" Or _
            varVal = "Cancelled - Missing Information Not Received" Or _
            varVal = "EC Not Covered Complete" Or _
            varVal = "Missing Information" Or _
            varVal = "Not Covered Complete - Diagnosis not covered" Or _
            varVal = "Not Covered Complete - Other - Not Covered" Or _
            varVal = "Not Covered Complete - Policy term" Then


                j = j + 1
                rng.EntireRow.Cut Destination:=rngLS
                Set rngLS = rngLS.Offset(1)
        End If
    Next
    Set ASR = Nothing
    Set LS = Nothing
    Set rng = Nothing
    Set rngLS = Nothing
    Application.Calculation = xlCalculationManual
End Sub