help to speed up this code

[nivek1012]

hey,

Does anybody have an idea how to speed up this code. Its work perfectly but is really slow when I need to the move line(s).
Code is triggered when workbook is saved.



kr
Kevin

Sub Move()

    Dim xRg, xCell As Range
    Dim i, J, K As Long


    
    i = Worksheets("New").UsedRange.Rows.Count
    J = Worksheets("Archive").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("New").Range("L3:L" & i)
    
    On Error Resume Next
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Done" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
 
    
    
End Sub

 

[Legacy 143009]

If you are deleting rows it is better to go backwards so you won't have to check for K twice or step back like k=k-1. I don't know your scenario exactly but try something like this. It should speed up things a bit:

For K = Rg.Count To 1 Step-1
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            J = J + 1
        End If
    Next

 

[nivek1012]

If you are deleting rows it is better to go backwards so you won't have to check for K twice or step back like k=k-1. I don't know your scenario exactly but try something like this. It should speed up things a bit:

For K = Rg.Count To 1 Step-1
        If CStr(xRg(K).Value) = "Done" Then
           [COLOR=rgb(65, 168, 95)] xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)[/COLOR]
            xRg(K).EntireRow.Delete
            J = J + 1
        End If
    Next

Hey thx for the reply but if i try your code on 1 row, then excel stops responding?
if tried running in steps en de error occurs when i hit this line (green txt).
Do you have any idea why?

 

[Legacy 143009]

As I told you before, I don't know your workbook structure exactly. You may have to mpdify it.

What do you mean by row 1? Does it stop immedietly on the first row? Can you share a sample file?

 

[johnnyL]

A XL2BB sample of the data would definitely help to speed up the code.

 

[johnnyL]

@nivek1012, we are waiting on you to respond to provide you with super fast code.

 

[Alex Blakenburg]

Welcome to the Forum Kevin,

As mentioned above you will generally get a better and faster response if you provide some representative sample data using the XL2BB tool.
It saves us having to manually recreate the data and gives us an idea of data types and data positioning and patterns. Some details are below.

Here is some code with some commentary on the existing code to get the ball rolling. If you have a lot of data it will be too slow. If that is the case the others will be happy to pitch in if you want to provide some sample data.

Sub Move()

    ' Dim xRg, xCell As Range       ' Only declares xCell as range, xRg will be variant
    ' Dim i, J, K As Long           ' Only declares K as long, i and J will be variant
    Dim xRg As Range, xCell As Range
    Dim i As Long, J As Long, K As Long
    Dim deleteRg As Range
 
    ' These will only work if the UsedRange starts from Row 1
    ' i = Worksheets("New").UsedRange.Rows.Count
    ' J = Worksheets("Archive").UsedRange.Rows.Count
    
    ' For New, since you are only testing in Column L you can use this
    i = Worksheets("New").Range("L" & Rows.Count).End(xlUp).Row
    ' For Archive since you are using Column A for the output you can use
    J = Worksheets("Archive").Range("A" & Rows.Count).End(xlUp).Row
    
    ' I would be inclined to assume you already have headings in place which means you can
    ' get rid of the next test
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0
    End If
    
    Set xRg = Worksheets("New").Range("L3:L" & i)
    
    On Error Resume Next
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then                     ' The CStr is unnecessary if done exists it will be a string
            J = J + 1
            xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J)
            
            ' Store Cells/Rows in order to delete them in one go later
            If deleteRg Is Nothing Then
                Set deleteRg = xRg(K)
            Else
                Set deleteRg = Union(xRg(K), deleteRg)
            End If
        End If
    Next
    
    If Not deleteRg Is Nothing Then                 ' Check that some rows have been found
        deleteRg.EntireRow.Delete
    Else
        MsgBox "No rows found that are flagged as Done"
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
     
End Sub

XL2BB​

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

 

[johnnyL]

A week later & still no clarifying response from the OP so the following is what I came up with that I assume will work & be very fast:

Sub Move()
'
    Dim i                           As Long, J  As Long
    Dim FilterStartRowData          As Long
    Dim OriginalL2                  As String
'
    i = Worksheets("New").UsedRange.Rows.Count                                                      '
    J = Worksheets("Archive").UsedRange.Rows.Count                                                  '
'
    If J = 1 Then                                                                                   '
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0      '
    End If
'
    On Error Resume Next                                                                            '
    Application.ScreenUpdating = False                                                              '
    Application.EnableEvents = False                                                                '
'
    FilterStartRowData = 3                                                                          ' <--- set this to to start row of the column Data to be filtered
'
    If Worksheets("New").Range("L" & FilterStartRowData - 1).HasFormula Then                        ' If L2 on the 'New' sheet has a formula then ...
        OriginalL2 = Worksheets("New").Range("L" & FilterStartRowData - 1).Formula                  '   Save the formula to OriginalL2
    Else                                                                                            ' Else ...
        OriginalL2 = Worksheets("New").Range("L" & FilterStartRowData - 1).Value                    '   Save the value of L2 from the 'New' sheet to OriginalL2
    End If
'
    Worksheets("New").Range("L" & FilterStartRowData - 1).Value = "Temp Header"                     ' Create a temporary Header for L2 on the 'New' sheet
    Worksheets("New").Range("L" & FilterStartRowData - 1 & ":L" & i).AutoFilter Field:=1, _
            Criteria1:="Done"                                                                       ' Auto filter column L on the 'New' sheet for values = 'Done'
    Worksheets("New").Range("L" & FilterStartRowData - 1) = OriginalL2                              ' Restore L2 on the 'New' sheet to its original state
'
    Worksheets("New").Rows(FilterStartRowData & ":" & i).SpecialCells(xlCellTypeVisible).Copy       ' Copy all visible remaining cell rows from the 'New' sheet range
    Worksheets("Archive").Range("A" & J + 1).PasteSpecial                                           ' Paste the cell rows to the next empty row on the 'Archive' sheet
    Worksheets("New").Rows(FilterStartRowData & ":" & i).SpecialCells(xlCellTypeVisible).Delete     ' Delete all of the visible rows in the 'New' sheet range
    Worksheets("New").AutoFilterMode = False                                                        ' Turn off the Auto filter on the 'New' sheet revealing the remaining rows of data
'
    Application.EnableEvents = True                                                                 '
    Application.ScreenUpdating = True                                                               '
End Sub

It doesn't use any loops, it uses 'AutoFilter'. Since we don't know what the value of L2 is, the script saves what is in L2, hijacks that cell to place a temporary header, does the filtering, then restores L2 to its original state.