Help Optimizing Copy Paste Rows Between Sheets Code

[baldbrian]

The below code works, but it takes about 5 minutes to complete. I was hoping someone might be able to share some tips on how to get this to run much faster? I really appreciate any help or advice. Thank you!

   While Len(Range("A" & CStr(LSearchRow)).Value) > 0
   
      'If value in column Q <> "RSD" and no trigger Activities, copy entire row to Not Released Report sheet     
      If Range("Q" & CStr(LSearchRow)).Value <> "RSD" And Range("O" & CStr(LSearchRow)).Value <> 100 And Range("O" & CStr(LSearchRow)).Value <> 200 And Range("O" & CStr(LSearchRow)).Value <> 250 And Range("O" & CStr(LSearchRow)).Value <> 400 Then
      
         'Select row in Data sheet to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         
         'Paste row into Not Released Report sheet in next row
         Sheet17.Select 'Not Released Report
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         
         'Go back to Data sheet to continue searching
         Sheet3.Select 'Data
         
         'Display Progress in Status Bar
         Application.StatusBar = False
         Application.StatusBar = "[Step 3 of 6] Update Not Released Report ... Percent Complete: " & Round((LSearchRow / pciCount) * 100, 0) & "%" '& " | " & LSearchRow & " of " & pciCount & " | nrrCount= " & nrrCount
         
      End If
      
      LSearchRow = LSearchRow + 1
       
   Wend

 

[Beyond_avarice]

Looping can become slow. Can you first sort your columns and use the Range.Find method to identify the first row and last row that your data is between(eg rows 52:88)? Start by finding the first instance(Row #) then repeat with the search order of "xlPrevious" to find the last row.

Selecting and Copy/Paste and bouncing between sheets; utilize computer resources and can slow you down. Instead try using the Find method and then assigning your Sheet17 value equal to the identified rows in Sheet3.

 

[baldbrian]

Thank you Beyond_avarice... So, would I need to basically create helper sheets and suck the data from my main sheet into another sheet where I do some sorting and then copy that data to another helper sheet where I sort some more, etc until I am just left with the data I wanted to copy in the first place?

 

[dmt32]

Hi,
Filtering your data & then copying to worksheet should be faster

Not fully tested but see if following does what you want

Option Base 1
Sub FilterToWorksheet()
    Dim arr As Variant
    Dim rng As Range
    Dim CriteriaRng As Range
    
'size data range
        Set rng = Sheet3.Range("A1").CurrentRegion
        
'values to exclude
        arr = Array("=""<>100""", "=""<>200""", "=""<>250""", "=""<>400""")
        
        
        With rng.Cells(1, rng.Columns.Count)
'add criteria header rows in unused part of sheet
            .Offset(, 2).Resize(, UBound(arr)).Value = rng.Cells(1, 15).Value
            .Offset(, UBound(arr) + 2).Value = rng.Cells(1, 17).Value
'add criteria
            .Offset(1, 2).Resize(, UBound(arr)).Value = arr
            .Offset(1, UBound(arr) + 2).Value = "<>RSD"
'size criteria range
            Set CriteriaRng = .Offset(, 2).Resize(2, UBound(arr) + 1)
        End With
          
'copy filtered data to sheet
        rng.AdvancedFilter Action:=xlFilterCopy, _
                            CriteriaRange:=CriteriaRng, _
                            CopyToRange:=Sheet17.Range("A1")
                            
'clear filter values
         CriteriaRng.Clear
        
End Sub

Note Option Base 1 statement which MUST be a TOP of your module OUTSIDE of any code.

As always, make backup of the workbook before testing new code.

Dave

 

[footoo]

Here's another possibility :

Dim LSearchRow#, lr#, rng As Range, LCopyToRow#, s, r#
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range(Cells(LSearchRow, "A"), Cells(lr, "A")).EntireRow
With Sheet17
    rng.Copy .Rows(LCopyToRow)
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = .Range(.Cells(LCopyToRow, "A"), .Cells(lr, "A")).Offset(0, 16)
End With
s = rng
For r = 1 To UBound(s)
    If s(r, 1) <> "RSD" And s(r, 1) <> 100 And s(r, 1) <> 200 And s(r, 1) <> 250 And s(r, 1) <> 400 Then s(r, 1) = "#N/A"
Next
rng.Value = s
rng.SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete