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?

 

[Kempy]

Hi the code is working brilliantly thanks but is it possible to have a second option within the code to move a row to a different sheet?

Lets say where the "dead" column has another option which is "completed" and when this is selected the row is moved to a sheet called "Completed Deals" rather than the "dead deals".

Here is my current code

    Dim Changed As Range
    Dim LastRow As Long
    
    Const DeadCol As String = "A" '<- Your 'Dead' column
    
    Set Changed = Intersect(Target, Columns(DeadCol))
    If Not Changed Is Nothing Then
    If MsgBox("Are you sure you want to change the status?", vbYesNo, "Change Status") = vbYes 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
        Rows("7:7").Select
    Selection.EntireRow.Hidden = True
    End If
    End If
End Sub

Many thanks

 

[Peter_SSs]

Hi the code is working brilliantly thanks but is it possible to have a second option within the code to move a row to a different sheet?

Lets say where the "dead" column has another option which is "completed" and when this is selected the row is moved to a sheet called "Completed Deals" rather than the "dead deals".

With the code below, I think you should be able to have as many 'statuses' as you want, provided there is a sheet with each status name followed by " Deals" to receive the moved rows.

Note that I have simplified, moved and commented out the code lines that re-hid row 7. If it turns out that you do still need that code line then you simply need to uncomment it.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Changed As Range, ToCopy As Range
  Dim LastRow As Long, i As Long
  Dim Status
  
  Const StatusCol As String = "A" '<- Your 'Status' column

  Set Changed = Intersect(Target, Columns(StatusCol))
  If Not Changed Is Nothing Then
    If MsgBox("Are you sure you want to change the status?", vbYesNo, "Change Status") = vbYes Then
      Status = Array("Dead", "Completed")  '<- Could add more Status values here
      Application.EnableEvents = False
      Application.ScreenUpdating = False
      LastRow = Range("A" & Rows.Count).End(xlUp).Row
      With Range(StatusCol & "7:" & StatusCol & LastRow)
        For i = LBound(Status) To UBound(Status)
          .AutoFilter Field:=1, Criteria1:=Status(i)
          On Error Resume Next
          Set ToCopy = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
          On Error GoTo 0
          If Not ToCopy Is Nothing Then
            With ToCopy.EntireRow
              .Copy Destination:=Sheets(Status(i) & " Deals") _
                .Range("A" & Rows.Count).End(xlUp).Offset(1)
              .Delete
            End With
            Set ToCopy = Nothing
          End If
        Next i
        .AutoFilter
      End With
'      Rows(7).Hidden = True
      Application.EnableEvents = True
      Application.ScreenUpdating = True
    End If
  End If
End Sub

 

[Kempy]

Once again works brilliantly. Thank you so much for your help.

Kempy

 

[jahbli]

Welcome to the MrExcel board!

You can make this happen automatically. Test in a copy of your workbook.

I have assumed that
a) data starts in column A and
b) that column A always has an entry in it by the time the two 'completed' columns are filled with 'YES'

To implement ...

1. Right click the 'TO DO' sheet name tab and choose "View Code".

2. Copy and Paste the code below into the main right hand pane that opens at step 1.

3. Close the Visual Basic window.

4. Try making changes in the sheet (especially columns M:N)



Private Sub Worksheet_Change(ByVal Target As Range)
****Dim Changed As Range
****
****Const YesCols As String = "M:N" '<- Your 'completed' columns
****
****Set Changed = Intersect(Target, Columns(YesCols))
****If Not Changed Is Nothing Then
********Application.EnableEvents = False
********Application.ScreenUpdating = False
********With Intersect(ActiveSheet.UsedRange, Columns(YesCols))
************.AutoFilter Field:=1, Criteria1:="=YES"
************.AutoFilter Field:=2, Criteria1:="=YES"
************With .Offset(1).EntireRow
****************.Copy Destination:=Sheets("ARCHIVE") _
********************.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 prfect! what i would to add is: i, ve got multiple sheets with diferent data but in every sheet is employee name. i would like to have macro that will move entire row of data from every sheet where is epmployee name to archive sheet. any help would be great. regards

 

[dbagnall]

Just curious as to what the code would look like if you wanted to run this from a command button. I tried to do this using the code above and assigning it to a command button and received a runtime error:

Sub btnArchive_Click()
Dim Changed As Range

Const FalseCol As String = "H" '<- Your 'completed' column

-> Set Changed = Intersect(Target, Columns(FalseCol))
If Not Changed Is Nothing Then
Application.EnableEvents = False
Application.ScreenUpdating = False
With Intersect(ActiveSheet.UsedRange, Columns(FalseCol)).Offset(1)
.AutoFilter Field:=8, Criteria1:="=FALSE"
With .Offset(1).EntireRow
.Copy Destination:=Sheets("ARCHIVE") _
.Range("A13" & Rows.Count).End(xlDown).Offset(1)
.Delete
End With
.AutoFilter
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub

My column is H which contains a formula that results in a True or False
My data begins a A13.

 

[RogueJenny]

Hi,

I'm so glad I found this....thank you in advance!

I need to use the same macro taking information from A:R in sheets 1-5 into Archive sheet 6 on completion of the word 'complete' in coloumn Q. I have tried adding the macro's you've put here on a new excel document but cannot get them to work at all. I'm all new to this macro business and could really use your help and it's costing me time at work.

Please help

 

[venkat1926]

sorry I am not physically well now. please post in a excel vba newsgroup along with some sample data. when you run the macro without command button does it work?

 

[retrogang]

Hi venkat1926

I tried to apply this code to my s'sheet but I am having some issues. I was wondering if you can help me with this. My data starts from A12 and I am trying to filter "431820" & "614075" in column F. The line with a bigger font size is where I am getting the error.

Sub Move_CC()
Dim r As Range, filtr As Range
With Worksheets("Sus Work")
Set r = .Range("A12").CurrentRegion
r.AutoFilter field:=.Range("F12").Column, Criteria1:="431820, 614075"
Set filtr = r.SpecialCells(xlCellTypeVisible)
'MsgBox filtr.Address
Set filtr = r.Offset(1, 0).Resize(r.Rows.Count - 1).SpecialCells(xlCellTypeVisible)

'MsgBox filtr.Address
filtr.Copy
With Worksheets("Deleted Lines")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
End With
filtr.EntireRow.Delete
r.AutoFilter
End With
End Sub

main data in sheet "TO DO" is from A1 with no blank rows or columns
you have another sheet "ARCHIVES"

try this macro

Sub test()
Dim r As Range, filtr As Range
With Worksheets("TO DO")
Set r = .Range("A1").CurrentRegion
r.AutoFilter field:=.Range("M1").Column, Criteria1:="yes"
r.AutoFilter field:=.Range("N1").Column, Criteria1:="yes"
Set filtr = r.SpecialCells(xlCellTypeVisible)
'MsgBox filtr.Address
Set filtr = r.Offset(1, 0).Resize(r.Rows.Count - 1).SpecialCells(xlCellTypeVisible)

'MsgBox filtr.Address
filtr.Copy
With Worksheets("ARCHIVES")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
End With
filtr.EntireRow.Delete
r.AutoFilter
End With
End Sub

 

[laubirch]

Hi Peter

I have a similar file where i want to archive data in Columns A to P where Column R (Past) is Yes, Id like to cut the cells within columns A to P to another sheet (Archived) and add onto the bottom so the archive sheet is a list of anything in the Past = Yes
Is this code able to be adapted for me to use to do this??

Thanks

Laura

With the code below, I think you should be able to have as many 'statuses' as you want, provided there is a sheet with each status name followed by " Deals" to receive the moved rows.

Note that I have simplified, moved and commented out the code lines that re-hid row 7. If it turns out that you do still need that code line then you simply need to uncomment it.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Changed As Range, ToCopy As Range
  Dim LastRow As Long, i As Long
  Dim Status
  
  Const StatusCol As String = "A" '<- Your 'Status' column

  Set Changed = Intersect(Target, Columns(StatusCol))
  If Not Changed Is Nothing Then
    If MsgBox("Are you sure you want to change the status?", vbYesNo, "Change Status") = vbYes Then
      Status = Array("Dead", "Completed")  '<- Could add more Status values here
      Application.EnableEvents = False
      Application.ScreenUpdating = False
      LastRow = Range("A" & Rows.Count).End(xlUp).Row
      With Range(StatusCol & "7:" & StatusCol & LastRow)
        For i = LBound(Status) To UBound(Status)
          .AutoFilter Field:=1, Criteria1:=Status(i)
          On Error Resume Next
          Set ToCopy = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
          On Error GoTo 0
          If Not ToCopy Is Nothing Then
            With ToCopy.EntireRow
              .Copy Destination:=Sheets(Status(i) & " Deals") _
                .Range("A" & Rows.Count).End(xlUp).Offset(1)
              .Delete
            End With
            Set ToCopy = Nothing
          End If
        Next i
        .AutoFilter
      End With
'      Rows(7).Hidden = True
      Application.EnableEvents = True
      Application.ScreenUpdating = True
    End If
  End If
End Sub

 

[Krishna_5592589]

Assuming your column J is not the result of a formula, you don't need many changes from the code posted above. Try this in a copy of your workbook. Implementation instructions in post #3.
Assumptions in post #3 also need to be true - post back with details if they are not.


Private Sub Worksheet_Change(ByVal Target As Range)
****Dim Changed As Range
****
****Const YesCol As String = "J" '<- 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:="=YES"
************With .Offset(1).EntireRow
****************.Copy Destination:=Sheets("ARCHIVE") _
********************.Range("A" & Rows.Count).End(xlUp).Offset(1)
****************.Delete
************End With
************.AutoFilter
********End With
********Application.EnableEvents = True
********Application.ScreenUpdating = True
****End If
End Sub

I have tried using this code but when I enter YES in column E (I have changed from J to E in code) the row Which I want to cut from "TO DO" and move in "ARCHIVE" sheet remains in the same 'TO DO' sheet and all other rows are moving and hiding in 'ARCHIVE' sheet. Can you please help me. I Can send my excel but looks like this forum is not allowed excel.