PDA

View Full Version : [SOLVED] Looping through cutting and pasting values between two dates



anne.gomes
06-16-2014, 07:23 PM
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
06-16-2014, 07:36 PM
Assuming that your date in in column A,



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


would probably work better

anne.gomes
06-16-2014, 07:49 PM
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
06-17-2014, 04:59 AM
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
06-17-2014, 02:28 PM
11839

Here is a dummy Workbook, Thanks.

mancubus
06-17-2014, 03:16 PM
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
06-17-2014, 03:36 PM
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
06-17-2014, 03:46 PM
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
06-17-2014, 04:24 PM
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
06-17-2014, 11:35 PM
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
06-17-2014, 11:35 PM
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 (http://www.amazon.com/Excel-VBA-Programming-For-Dummies/dp/1118490371), by John Walkenbach
Engineering with Excel (http://www.amazon.com/Engineering-Excel-3rd-Ronald-Larsen/dp/0136017754/), by Rober W. Larsen
Excel 2010 Bible (http://www.amazon.com/Excel-2010-Bible-John-Walkenbach/dp/0470474874/), by John Walkenbach

Some of the websites I have found very useful:

This forum! (http://www.vbaexpress.com/forum)
PeltierTech (http://peltiertech.com/Excel/)
Pearson Software Consulting
(http://www.cpearson.com/excel/topic.aspx)

I hope this can be of some help to you!

anne.gomes
06-18-2014, 06:25 PM
Thanks EirikDaude :)

anne.gomes
06-21-2014, 12:07 AM
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
06-21-2014, 09:34 AM
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
06-21-2014, 11:58 AM
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
06-21-2014, 01:11 PM
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
06-21-2014, 02:23 PM
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
06-21-2014, 03:15 PM
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
06-21-2014, 04:06 PM
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
06-22-2014, 03:31 PM
11852

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

mancubus
06-23-2014, 01:01 AM
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
06-23-2014, 02:00 AM
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
06-23-2014, 02:27 AM
welcome.

afaik, progress bars mostly increase the code execution times.

Paul_Hossler
06-23-2014, 09:01 AM
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
06-23-2014, 02:00 PM
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
06-23-2014, 02:34 PM
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
06-23-2014, 02:50 PM
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
06-23-2014, 03:25 PM
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
06-23-2014, 03:58 PM
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. :hi:

mancubus
06-24-2014, 12:17 AM
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
06-24-2014, 09:27 PM
Thanks mancubus :)

mancubus
06-25-2014, 01:20 AM
welcome.

does that mean it's solved? :)

anne.gomes
06-25-2014, 03:01 PM
Yup, Thank you :) :) :)

mancubus
06-26-2014, 12:14 AM
you're welcome.

thanks for the feedback and marking the thread as solved.