MACRO to Archive Rows to separate workbook

[elemnt55]

My work has a very large schedule they work from and is causing opening times of up to 45min for some. I am looking for a macro to archive older rows to a separate workbook on the server based on the "completed date" column.

the workbook is xls but some use 2010 office. I am currently using 2010.

This workbook is accessed by many users within the company as read only.

Thanks for any help!

 

[Momentman]

What constitutes an older row?

Could you please give some sample data so that a macro that fits your data can be developed

 

[elemnt55]

We would prefer to archive rows based on date in format xx/xx/xx. An older row would be any row before a shipped date that we decide. So any date before 12/1/11 we would like to archive to a separate workbook. Also there are multiple worksheets within the workbook we would like to apply this to.

The determining column is labeled shipped or column AE. There are 20 columns of data all with first row titles.

The workbook name is 2010sch.xls and we would like to archive to 2010scharchive.xls if possible.

Shipped
11/16/11
11/17/11

 

[Momentman]

Let's give this macro a try

Please change the path of the activeworkbook.saveas to a path on your computer

You will be required to key in or input the cutoff date at somepoint (enter it in the form dd/mm/yy)

Sub newdata2()
    Dim wks As Workbook
    Dim cutoff As Date
    
    ActiveWorkbook.SaveAs "c:\users\" & "2010scharchive.xlsm", FileFormat:=52
    cutoff = InputBox("Enter Date to cut-off in dd/mm/yy:", "Select Last date")
    
    For I = 1 To ActiveWorkbook.Worksheets.Count
        Worksheets(I).Activate
        lastrow = Range("A1").End(xlDown).Row
        For j = lastrow To 2 Step -1
            k = Cells(j, "AE").Value
            If Cells(j, "AE").Value < cutoff Then
            Rows(j).Delete
            End If
        Next j
    Next I
End Sub

 

[Momentman]

Yet Another way

All you need is to input the cutoff date when prompted e.g 13/01/2011 for 13th January 2011

It would then create a new workbook called 2010scharchive with the data required

"Please change the path at the bottom of the macro where it says "c:\users\momentum\" to a path on your system"

Sub newfilter()
    Dim wks As Workbook
    Dim cutoff As Date
    Dim rng As Range
    j = 1
    Set wks = ActiveWorkbook
    
    cutoff = InputBox("Enter Date to cut-off in dd/mm/yy:", "Select Last date")
    
    For I = 1 To ActiveWorkbook.Worksheets.Count
        wks.Activate
        Worksheets(I).Activate
        lastrow = Range("A1").End(xlDown).Row
        
        Set rng = Range("A1:AE" & lastrow)
        
        rng.AutoFilter field:=31, Criteria1:="<" & cutoff, Operator:=xlAnd
        rng.SpecialCells(xlCellTypeVisible).Select
        Selection.Copy
        
        If j = 1 Then
            Set wksnew = Workbooks.Add
            Worksheets(j).Activate
            ActiveSheet.Paste
        ElseIf j > 1 Then
            wksnew.Activate
            Worksheets(j).Activate
            ActiveSheet.Paste
        End If
                      
        j = j + 1
    Next I
    ActiveWorkbook.SaveAs "c:\users\Momentum\" & "2010scharchive.xlsm", FileFormat:=52
        
End Sub