Macro to Move Cells to Archive Sheet

[SpacemanSpif]

Hi there, longtime user firsttime poster. Looking for some help as I am a non-expert with macros. Here's what I'm trying to do:

We have to submit things to a certain regulatory body and we usually enter tasks in as soon as they come, do the submission, and then keep a record of that submission.

So, I have a workbook with two sheets, one is "TO DO", the other is "ARCHIVE". Both sheets have the same columns and everything. I am looking for a macro that will automatically cut a (row) from the TO DO sheet and paste it in into the ARCHIVE sheet once it is done, then delete the cut row from the TO DO list so it stays topped up.

The trigger for archiving is the columns M and N which are titled "Complete ?" and each has a validation drop down that says "YES". When both cells in columns M and N have the YES in them, I would like the macro to make the above mentioned actions.

I ran a search on the forums and found something similar, but not quite what I was looking for.

Any help?

 

[Desmondo]

Hmm, so you have a 'To Do' list that occupies 65,000+ (if using Excel 2003) or 1,000,000+ (if using Excel 2007+) rows? That should keep you busy for a while!!

I have no idea why you would be using so may rows for a 'To Do' list, but in any case try this version.
Again ensure that your Events have not been disabled.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Changed As Range
  Dim lr As Long
  
  Const YesCol As String = "I" '<- Your 'Yes' column
  
  Set Changed = Intersect(Target, Columns(YesCol))
  If Not Changed Is Nothing Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    lr = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, _
      SearchOrder:=xlByRows, SearchDirection:=xlPrevious, SearchFormat:=False).Row
    With Intersect(Rows("2:" & lr), Columns(YesCol))
      .AutoFilter Field:=1, Criteria1:="=YES"
      If .SpecialCells(xlVisible).Cells.Count > 1 Then
        With .Resize(.Rows.Count - 1).Offset(1).EntireRow
          .Copy Destination:= _
            Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Offset(1)
          .Delete
        End With
      End If
      .AutoFilter
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  End If
End Sub

Peter,

You are a genius!

thank you very much all is working perfectly now.

Thanks, Thanks & Thanks

This will save me a ton of time at work

 

[Kempy]

Try this version in a copy of your workbook.
You would put this code in the '2013 Job Sheet' module (ie Right click '2013 Job Sheet' > View Code)

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Changed As Range
    Dim LastRow As Long
    
    Const DeadCol As String = "O" '<- Your 'Dead' column
    
    Set Changed = Intersect(Target, Columns(DeadCol))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        LastRow = Range("A" & Rows.Count).End(xlUp).Row
        With Range(DeadCol & "7:" & DeadCol & LastRow)
            .AutoFilter Field:=1, Criteria1:="=DEAD"
            With .Offset(1).EntireRow
                .Copy Destination:=Sheets("Dead Deals") _
                    .Range("A" & Rows.Count).End(xlUp).Offset(1)
                .Delete
            End With
            .AutoFilter
        End With
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

This works brilliantly thanks.

One thing is, if a row is inserted it sends all of the data from the "live" sheet to the "dead". Is there a way around this or do i need to protect the worksheet so that rows cannot be inserted?

Many thanks for all your help.

Kempy

 

[Peter_SSs]

One thing is, if a row is inserted it sends all of the data from the "live" sheet to the "dead". Is there a way around this or do i need to protect the worksheet so that rows cannot be inserted?

I don't believe anything in the code I posted would do that, so..

1. Have you changed the code in any way? If so, please post your current code (use Code tags as shown in my signature block)

2. Describe as well as you can what you have (or had) on the 2013 Job Sheet (I assume that is what you now refer to as the "live" sheet)

3. Describe exactly what you did that caused the loss of data. That is, what sheet you were on and what actions you took, including just where you inserted the row.

 

[Kempy]

Your comments made me go and try a few things and it appears that the issue was possibly being caused by having a hidden row at row 237

The code i am using is exactly as you created it. With the hidden row, if i inserted a row anywhere before row 237 all of the data would be cut and pasted into "dead deals" sheet and the rows pasted would all be hidden.

If i unhide row 237 the problem no longer occurs!

 

[Peter_SSs]

Hmm.. I've been unable to reproduce that behaviour.

 

[Brack]

Peter - I've updated your code to work with my spreadsheet - same basic idea, but I have a few issues I'd like to see where I'm going wrong on...

here's my code as I've edited it:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Changed As Range
    
    Const YesCol As String = "T" '<- Your 'completed' column
    
    Set Changed = Intersect(Target, Columns(YesCol))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        With Intersect(ActiveSheet.UsedRange, Columns(YesCol)).Offset(1)
            .AutoFilter Field:=1, Criteria1:="=Y"
            With .Offset(1).EntireRow
                .Copy Destination:=Sheets("Closed Equipment") _
                    .Range("A" & Rows.Count).End(xlUp).Offset(1)
                .Delete
            End With
            .AutoFilter
        End With
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If


End Sub

This is copying my header as well, which has active filters and doesn't start until row 3. The archive is set in column "T", and my data is from columns A:AA, and data is usually about 50-60 records long (the closed/archive worksheet has about 1000 rows now). I have the top 3 rows frozen, would that make a difference?

Also, when I move the row to the "Closed Equipment" worksheet, I would like to paste values, instead of copying the formulas over...

That said, this looks like a very clean solution to moving archive records! Thanks for posting this!

 

[Peter_SSs]

This is copying my header as well, which has active filters and doesn't start until row 3. The archive is set in column "T", and my data is from columns A:AA, and data is usually about 50-60 records long (the closed/archive worksheet has about 1000 rows now). I have the top 3 rows frozen, would that make a difference?

Also, when I move the row to the "Closed Equipment" worksheet, I would like to paste values, instead of copying the formulas over...

That said, this looks like a very clean solution to moving archive records! Thanks for posting this!

See if these few changes do what you want. Changes highlighted.
I wasn't quite sure if your headers are in row 3 or your data starts in row 3. Anyway, just set the header row in the relevant 'Const' line.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Changed As Range
    
    Const YesCol As String = "T"  '<- Your 'completed' column
    Const HeaderRow As Long = 3   '<- Header row in main sheet
    
    Set Changed = Intersect(Target, Columns(YesCol))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        With Intersect(ActiveSheet.UsedRange, Columns(YesCol), Rows(HeaderRow & ":" & Rows.Count))
            .AutoFilter Field:=1, Criteria1:="=Y"
            With .Offset(1).EntireRow
                .Copy
                Sheets("Closed Equipment").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                .Delete
            End With
            .AutoFilter
        End With
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

 

[Brack]

That works great!

It didn't quite work the first time I ran it, but it has run perfect every time since then! Thank you so much!

One other thing I'm trying to work around is that column A has a formula that is based the cell above it, and when I archive a record, all records below turn to #REF! because the cell is no longer there. Cell A3 has text in it (being my header row), and cell A4 has the following formula:

=SUM(A3,AND(S4>=$D$2, S4<=$D$2+7, N4=0))

D2 is TODAY(), Column S is the cycle date, and Column N is the call-off date. The formula determines which records have equipment coming due in the next week, and provides me with a running count on those records. I'm doing a VLOOKUP on those records in another sheet that has some preset formatting and columns hidden so that I generate an easy-to-read report I can PDF and send to my superintendents.

The code you provided above is still making my job easier, even if I have to copy the formula down after archiving, though! Thanks so much!

 

[Peter_SSs]

One other thing I'm trying to work around is that column A has a formula that is based the cell above it, and when I archive a record, all records below turn to #REF! because the cell is no longer there. Cell A3 has text in it (being my header row), and cell A4 has the following formula:

=SUM(A3,AND(S4>=$D$2, S4<=$D$2+7, N4=0))

Try this

1. Insert a new row 4. Place a 0 in cell A4. Hide the new row 4.

2. Your top row of data is now row 5. Put this formula in A5 and copy down.

=SUM(LOOKUP(9.99E+307,A$4:A4),AND(S5>=$D$2, S5<=$D$2+7, N5=0))

3. Add this extra line of code

            .AutoFilter
        End With
        Rows(4).Hidden = True
        Application.EnableEvents = True

 

[Brack]

that is AMAZING! Everything works great, and the LOOKUP function was brilliant!

thanks!!!