Looping through cutting and pasting values between two dates

[anne.gomes]

Hi,

So I have written this code, I have a error at the moment on line

If .Cell(i, "A").value < StartDate

What I am trying to do is, loop through a worksheet and for all the dates older than two days from the current date I want to cut and paste it into a new worksheet in the same workbook called "Archive". Do this for all the dates in column A that has the value in the cell of older than 2 days prior to current date.

Then What I want to do is delete all the empty rows left behind by the copy and pasting so all the remaining data (which are dates that are beween two days ago and current date) will move up.

Here is my code:

Sub Final_Cleanup()
Dim EndDate As Date
Dim StartDate As Date
Dim i As Long
today = Date
StartDate = today - 2
EndDate = today
Worksheets("Invoice").Activate
With Sheets("Invoice")
LR = .Cells(Rows.Count, "A").End(xlUp).Row
For i = LR To 2 Step -1
If .Cell(i, "A").value < StartDate Then
.Rows(i).EntireRow.Cut
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Archive"
ActiveSheet.Range("A1").Select
ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next i
End With
ActiveSheet.SaveAs Filename:="C:\Users\anneg\Desktop\Archive\Archive.xlsm"
Worksheets("Invoice").Activate
With Application
For i = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
 Selection.Rows(i).EntireRow.Delete
 
End If
Next i
End With
ActiveWorkbook.Save
End Sub

Any help much appreciated!

Thank you

[Paul_Hossler]

Assuming that your date in in column A,

If .Cell(i, 1).value < StartDate Then

would probably work better

[anne.gomes]

Hi Paul_Hossler, I tried your line and I still get the error "Pbject doesn't support this property or method". And yes the date goes down column A. Any more suggestions?

[Paul_Hossler]

Could you could post a small sample workbook with the problem since I'm not sure which statement is generating the error?

Also did you change all of the "A" references to 1?

Like this on, and any others?

 LR = .Cells(Rows.Count, "A").End(xlUp).Row 

should be 1 and with a dot in front of Rows

[CODE]
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
[/CODE

[anne.gomes]

Dummy Workbk.xlsm

Here is a dummy Workbook, Thanks.

[mancubus]

hi there.

just a reminder.

as you know, when you add a worksheet, it becomes the ActiveSheet. A1 is ActiveCell.

so Range("A1").End(xlDown) is the last cell in Colum A, which is A1048576. and offsetting it by one row will throw rte 1004 application-defined or object-defined error.

[mancubus]

here is something for the first part:

Sub Final_Cleanup()
    Dim StartDate As Date, EndDate As Date
    Dim i As Long
     
    StartDate = DateSerial(Year(Date - 2), Month(Date - 2), Day(Date - 2))
    EndDate = DateSerial(Year(Date), Month(Date), Day(Date))


    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Archive"
    
    With Worksheets("Sheet1")
    For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
        If CLng(.Cells(i, 1).Value) < CLng(StartDate) Then
            .Rows(i).Copy Destination:=Worksheets("Archive").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            .Rows(i).Cells.Clear
        End If
    Next i
    End With
End Sub

[anne.gomes]

Hi, Thanks for that, your code semi works.... When I run it, it doesn't pick up the A1 value and also the new Archive worksheet doesn't display the date just ####. Can I put .Show or something for the date to appear?

Thanks so much

[anne.gomes]

Mancubus, I just needed to expand the column, man im dump :P

Thank you so much!!!

I want to expand my vba knowledge, could you please direct me to some resources if you can?

Thank you

[mancubus]

you are welcome.

Sub Final_Cleanup()
    
    Dim StartDate As Date, EndDate As Date
    Dim i As Long, calc As Long
     
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    StartDate = DateSerial(Year(Date - 2), Month(Date - 2), Day(Date - 2))
    EndDate = DateSerial(Year(Date), Month(Date), Day(Date))
     
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Archive"
     
    With Worksheets("Sheet1")
        .Rows(1).Copy Destination:=Worksheets("Archive").Cells(1)
        'copies the header row. delete above line if there is no header row
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If CLng(.Cells(i, 1).Value) < CLng(StartDate) Then
                .Rows(i).Copy Destination:=Worksheets("Archive").Cells(Rows.Count, 1).End(xlUp).Offset(1)
                .Rows(i).Clear
            End If
        Next i
    End With
    Worksheets("Archive").Columns.AutoFit
    
    ThisWorkbook.SaveAs Filename:="C:\Users\anneg\Desktop\Archive\Archive.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
    With ActiveWorkbook
        With .Worksheets("Invoice")
            For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
                If Application.CountA(.Rows(i)) = 0 Then .Rows(i).EntireRow.Delete
            Next i
        End With
        .Save
    End With

    With Application
        .EnableEvents = True
        .Calculation = calc
    End With
End Sub

[EirikDaude]

While I am in no way an expert, I have found that simply writing modules and googling / asking on forums when I am stuck has made me learn quite a bit. This does of course take quite a while, but unless you are prepared to pay for and/or take time off from work to participate in courses, I think it is the best options.

The books I have perused as reference material while learning VBA/Excel are:

• Excel VBA Programming for Dummies, by John Walkenbach
• Engineering with Excel, by Rober W. Larsen
• Excel 2010 Bible, by John Walkenbach

Some of the websites I have found very useful:

• This forum!
• PeltierTech
• Pearson Software Consulting
  

I hope this can be of some help to you!

[anne.gomes]

Thanks EirikDaude

[anne.gomes]

Hi,

So the code so far works for smaller chunks of data but for data containing 500,000 rows of data, it takes over 3 hours to compile. I was wondering if the following line would make it faster to compile by selecting 10,000 rows at oncea and copying and pasting.

Sub Final_Cleanup()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim StartDate As Date, EndDate As Date
Dim i As Long
     
    StartDate = DateSerial(Year(Date - 20), Month(Date - 20), Day(Date - 20))
    EndDate = DateSerial(Year(Date), Month(Date), Day(Date))
     
    On Error Resume Next
    'Sheets("Archive").Delete
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Archive" 
n Error GoTo 0
    With Worksheets("Invoice")
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To  10000 Step-1
            If IsDate(.Cells(i, 1)) Then
                If CLng(.Cells(i, 1).Value) < CLng(StartDate) Then
                    .Rows(i).Copy Destination:=Worksheets("Archive").Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    .Rows(i).Cells.Clear
                End If
            End If
        Next i
    End With

Application.ScreenUpdating = True
ication.Calculation = xlCalculationAutomatic
on.DisplayAlerts = True
Application.EnableEvents = True
    
 Exit Sub
End Sub

Does the line

 For i = .Cells(.Rows.Count, 1).End(xlUp).Row To  10000 Step-1

work for selecting 10,000 rows at once and then copying it to the Archive Workheet?

Thanks in advance

[EirikDaude]

As far as I can tell, that line will make you start at the bottom row of the sheet, and then work its way upward to row 10000 before it stops. If it starts above row 10000, I think the sub will crash.

Is there any reason you want to count from the bottom upwards? Otherwise something like

For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row Step 10000

should work. You still have to decide what to do if it encounters a blank cell, but it should still be (slightly) easier than putting in code preventing it from hitting rows with a number <1.
You'll also have to switch the line where you decide what range to copy a bit:

Range(.Rows(i), .Rows(i+9999)).Copy Destination:=Worksheets("Archive").Cells(Rows.Count, 1).End(xlUp).Offset(1)

I think that should work, not at my work-computer, so I don't get to test the code :P

[Paul_Hossler]

Assuming the data starts in row 1, I'd do it in something like 2 passes, one to copy over and then one to delete the copied rows (deleting rows is faster going from bottom up)

really should only take seconds even with 500,000 rows

Option Explicit
Sub Final_Cleanup()
     
    Dim StartDate As Date, EndDate As Date
    Dim iInvoiceRow As Long, iArchiveRow As Long
     
    'set configuration
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Application.EnableEvents = False
     
    StartDate = DateSerial(Year(Date - 20), Month(Date - 20), Day(Date - 20))
    EndDate = DateSerial(Year(Date), Month(Date), Day(Date))
     
    On Error Resume Next
    Sheets("Archive").Delete
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Archive"
    On Error GoTo 0
    
    
    'pass 1 to copy the rows top to bottom
    iArchiveRow = 1
    
    With Worksheets("Invoice")
        For iInvoiceRow = 1 To .Cells(1, 1).CurrentRegion.Rows.Count
            If IsDate(.Cells(iInvoiceRow, 1)) Then
                If CLng(.Cells(iInvoiceRow, 1).Value) < CLng(StartDate) 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 1 Step -1
            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
     
    Exit Sub
End Sub

[mancubus]

do you want to delete the copied rows or clear contents of copied rows?

if you want to delete the rows, using a helper column to mark the rows and filtering the range on helper column and thenn deleting the filtered rows will be mach faster.


if you post your workbook (confidential data replaced with fake data) helping will be easier.

[anne.gomes]

Hi Paul_Hossler, Thank you for your reply, the rows I have is actually 28 million... so it is still taking quite some time with your code also. Any way to speed it up even more?

mancubus, yes I was deleting the empty rows, I didn't post that bit of code on here as I thought the problem was with the first half, I will try and post some data but as it is so big I doubt I will be able to...sorry

[mancubus]

no need to post whole workbook. 50-100 rows of data which meet your requirement.

btw, if you are dealing with 28 million records, i think, excel (perhaps access too) is not the answer.

[Paul_Hossler]

the rows I have is actually 28 million... so

An Excel 2017/2010 worksheet has about 1 million rows.

Do you mean that you have 28 worksheets mostly full???

In a single workbook?????

[anne.gomes]

Book1.xlsm

Here is some data, I don't know why it takes so long to compile...When I run it, the workbook goes into 'no response' and blanks out but the code in Visual Basic is set as running.... Any ideas?

And Paul_Hossler, I got confused, it is only using 500,000 rows, but the worksheet has formulars etc that are repeatedly copied down as attached above just a snippet. So maybe that is why it is taking over an hour to compile?

Thanks