Looping through cutting and pasting values between two dates

[mancubus]

it's pretty fast.
because no records meet the conditions.
the dates are all "20 June 2014".

i assume Row 1 is header row.

if your table does not have one, i recommend you add manually. insert a blank row, type "Header1" in A1, drag the cell from its bottom-right corner (click and hold left mouse button) to the rightmost column with data.

Sub Final_Cleanup()
'assumtion: Row 1 is header row
    Dim StartDate As Date, EndDate As Date
    Dim i As Long, calc As Long, LastRow As Long, LastCol As Long
    Dim PasteRange As Range
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    StartDate = DateSerial(Year(Date - 20), Month(Date - 20), Day(Date - 20))
    EndDate = DateSerial(Year(Date), Month(Date), Day(Date))
    
    On Error Resume Next
    Worksheets("Archive").Delete
    On Error GoTo 0
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Archive"
    
    With Worksheets("Invoice")
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        
        For i = 2 To LastRow
            If IsDate(.Cells(i, 1)) Then
                If CLng(.Cells(i, 1).Value) < CLng(StartDate) Then
                Set PasteRange = Worksheets("Archive").Cells(Rows.Count, 1).End(xlUp).Offset(1)
                PasteRange.Resize(, LastCol).Value = .Range(.Cells(i, 1), .Cells(i, LastCol)).Value
                .Cells(i, LastCol + 1).Value = "Del"
                End If
            End If
        Next i
        
        .Cells(1).AutoFilter Field:=LastCol + 1, Criteria1:="=Del"
        .UsedRange.Columns(1).Offset(1).SpecialCells(12).EntireRow.Delete '12 = xlCellTypeVisible
        .AutoFilterMode = False
        .UsedRange.Columns(LastCol + 1).ClearContents
    End With
    
    With Application
    .EnableEvents = True
    .Calculation = calc
    End With
End Sub

[anne.gomes]

Thank you, will try that tomorrow. Is there a way I can do a
progress bar and for it to not slow down the code anymore?

[mancubus]

welcome.

afaik, progress bars mostly increase the code execution times.

[Paul_Hossler]

1. You have links to a workbook called 'Basware Daily Report Data.xlsm' -- needed?

2. In your Book1.xlsm I don't see any formulas, just data.

3. You said 'compile' -- that's something different than 'complete' or 'run' or 'execute' or 'finally get done' -- no biggie, just terminology

4. Application.Statusbar does not slow it down as much as a progress bar

5. Your Book1.xlsm did not have any macros in it, so I used my previous post and updated ...

6. I had to fiddle some dates for test since they were all 6/20

Option Explicit
Sub Final_Cleanup()
    Dim iNumberOfDaysInPast As Long
    Dim iInvoiceRow As Long, iArchiveRow As Long, iTotalRows As Long
     
     'set configuration
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Application.EnableEvents = False
     
     
    iNumberOfDaysInPast = 20
     
    On Error Resume Next
    Sheets("Archive").Delete
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Archive"
    On Error GoTo 0
     
    With Worksheets("Invoice")
    
        'copy header
        Call .Rows(1).Copy(Worksheets("Archive").Rows(1))
     
         'pass 1 to copy the rows top to bottom
        iArchiveRow = 2
        iTotalRows = .Cells(1, 1).CurrentRegion.Rows.Count
        For iInvoiceRow = 2 To iTotalRows
            
            If iInvoiceRow Mod 100 = 0 Then Application.StatusBar = "Pass #1 - " & Format(iInvoiceRow, "#,###") & " of " & Format(iTotalRows, "#,###")
            
            If IsDate(.Cells(iInvoiceRow, 1)) Then
                If CLng(.Cells(iInvoiceRow, 1).Value) < Date - iNumberOfDaysInPast Then
                    Call .Rows(iInvoiceRow).Copy(Worksheets("Archive").Rows(iArchiveRow))
                    .Cells(iInvoiceRow, 1).Value = True '   marker to delete next pass
                    iArchiveRow = iArchiveRow + 1
                End If
            End If
        Next iInvoiceRow
    End With
     
     'pass 2 to delete the marked rows bottom to top
    With Worksheets("Invoice")
        For iInvoiceRow = .Cells(1, 1).CurrentRegion.Rows.Count To 2 Step -1
            If iInvoiceRow Mod 100 = 0 Then Application.StatusBar = "Pass #1 - " & Format(iInvoiceRow, "#,###") & " of " & Format(iTotalRows, "#,###")
            If .Cells(iInvoiceRow, 1).Value = True Then .Rows(iInvoiceRow).Delete
        Next iInvoiceRow
    End With
     
     
     'reset configuration
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.StatusBar = False
     
    Exit Sub
End Sub

[anne.gomes]

mancubus, I get an error on

.Cells(1).AutoFilter Field:=LastCol + 1, Criteria1:="=Del"

... but your code seems to working pretty fast up until that line of code.

Paul_Hossler - Thank you for taking so much effort with your answer, your Application status bar is working fine, however it is still taking a very long time to run. I think Auto filter is the only thing that will speed up the run time....

[mancubus]

i dont duplicate the error. works fine for me with the uploaded file.
what error message do you get?




sorting the range on helper column before deleting the rows will speed up the code.

i added another helper column to keep the row order.

if you are sure all values in column A are dates, deleting the first condition (If IsDate(.Cells(i, 1)) Then) will also speed up the code.

Sub Final_Cleanup()
    
    Dim StartDate As Date, EndDate As Date
    Dim i As Long, calc As Long, LastRow As Long, LastCol As Long
    Dim PasteRange As Range
     
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
     
    StartDate = DateSerial(Year(Date - 20), Month(Date - 20), Day(Date - 20))
    EndDate = DateSerial(Year(Date), Month(Date), Day(Date))
     
    On Error Resume Next
    Worksheets("Archive").Delete
    On Error GoTo 0
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Archive"
     
    With Worksheets("Invoice")
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        .Cells(1, LastCol + 1).Value = "Mark"
        .Cells(1, LastCol + 2).Value = "Seq No"
        
        For i = 2 To LastRow
            .Cells(i, LastCol + 2).Value = i
            If IsDate(.Cells(i, 1)) Then
                If CLng(.Cells(i, 1).Value) < CLng(StartDate) Then
                    Set PasteRange = Worksheets("Archive").Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    PasteRange.Resize(, LastCol).Value = .Range(.Cells(i, 1), .Cells(i, LastCol)).Value
                    .Cells(i, LastCol + 1).Value = "Del"
                End If
            End If
        Next i
         
        .UsedRange.Sort Key1:=.Cells(2, LastCol + 1), Order1:=xlAscending, Header:=xlYes
        .Cells(1).AutoFilter Field:=LastCol + 1, Criteria1:="=Del"
        .UsedRange.Columns(1).Offset(1).SpecialCells(12).EntireRow.Delete '12 = xlCellTypeVisible
        .AutoFilterMode = False
        .UsedRange.Sort Key1:=.Cells(2, LastCol + 2), Order1:=xlAscending, Header:=xlYes
        .UsedRange.Columns(LastCol + 1).ClearContents
        .UsedRange.Columns(LastCol + 2).ClearContents
    End With
     
    With Application
        .EnableEvents = True
        .Calculation = calc
    End With
End Sub

[anne.gomes]

Error is 'Run-time error Sort method of Range class failed for

 .UsedRange.Sort Key1:=.Cells(2, LastCol + 1), Order1:=xlAscending, Header:=xlYes

this code is taking more time the previous piece of code.

For the last line that threw an error the error was "Autofilter method of Range class failed" for

        .Cells(1).AutoFilter Field:=LastCol + 1, Criteria1:="=Del"

And not all values are Dates so I need IsDate

[mancubus]

there may be blank columns in the usedrange. so make sure row 1 has headers for all columns in the used range. insert dummy header names where necessary.

i attach my test file.

i added a line to remove existing filters after .... With Works..... line.

[anne.gomes]

Hi mancubus, I keep getting 'Autofilter method of Range class failed' error on line .Cells(1).AutoFilter Field:=LastCol + 1, Criteria1:="=Del". I think I will just use the code without Autofilter even though it takes an extremely long time. But this lot of code only needs to be done once a month which is okay. I could just do it more regularly so that there is less data to go through which is the main problem I think for the slowness.

Thank you for all your help though and everyone's help. I really appreciate it.

[mancubus]

you're welcome.

insert Exit Sub after Next i line so rest of the code will not be executed.

after running the code, click "macro recorder", manually select, sort, filter used range (include last two columns added by above code), click "stop recording".

paste recorded macro here.

[anne.gomes]

Thanks mancubus

[mancubus]

welcome.

does that mean it's solved?

[anne.gomes]

Yup, Thank you

[mancubus]

you're welcome.

thanks for the feedback and marking the thread as solved.