VBA - Archiving old data onto next available row of seperate worksheet

[cd254]

Hi! First time poster and neophyte VBA user. I am attempting to copy and paste a row from worksheet "REGISTER" to the next available row in worksheet "ARCHIVE" whenever "Yes" is recorded in Column O of REGISTER. I have used the following code, taken from another forum, which manages to copy the row into ARCHIVE and deletes the old data from REGISTER, but when the next row has "Yes" recorded it overwrites the same row in ARCHIVE. I have tried many solutions, but each one keeps overwriting the same row in archive. Can someone please show me where I'm going wrong!?

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Changed As Range
    
    Const YesCol As String = "O"  '<- Your 'completed' column
    Const HeaderRow As Long = 10   '<- 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:="=Yes"
            With .Offset(1).EntireRow
                .Copy
             .Copy Destination:=Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .ClearContents
            End With
            .AutoFilter
        End With
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

 

[mrmmickle1]

Hey welcome to the board. Hopefully this will help out.
The code you have is finding the last row of data in column A in the sheet "ARCHIVE" and then moving one row below that (Thus the Offset(1))....

[COLOR=#ff0000].Copy Destination:=Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Offset(1)[/COLOR]

Do you have contiguous data in column A?
Try inserting a few lines like this above the line I reference:

LastCellColA = [COLOR=#333333]Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Address
MsgBox LastCellColA[/COLOR]

Then run the code again. See if the message box reflects the correct last cell in Column A. If you have gaps in data or a "" (NULL Value) in column A it will overwrite the previous row....

 

[cd254]

Thanks mrmickle1! Your code pointed me in the right direction and I was able to work out my error!. I have a slightly different query now... When I run the code below I want it to delete the row of data after it has copied over to the Archive sheet, which it is now doing correctly. However, I have formulas in the REGISTER sheet, so would ideally want to protect them from being deleted when I eventually pass this document over to my colleagues, but when I add the "locked cells" protection to these cells it prevents the VBA from running. Do you know of a clause that I can add into my code in order to allow protected cells to be deleted by the VBA or an alternative way of protecting formulas? Thanks so much for your help!

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Changed As Range
    
    Const YesCol As String = "O"
    Const HeaderRow As Long = 10
    
    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:="=Yes"
            With .Offset(1).EntireRow
                .Copy
                LastCellColB = Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Address
             .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

 

[mrmmickle1]

If I understand your issue correctly maybe you can add this to the code. It will un-protect the worksheet to complete the procedure and then re-protect it after the procedure has run.

 [COLOR=#0000ff] Private Sub [/COLOR]Worksheet_Change([COLOR=#0000ff]ByVal[/COLOR] Target [COLOR=#0000ff]As[/COLOR] Range)  [COLOR=#0000ff]  

    Dim[/COLOR] Changed [COLOR=#0000ff]As[/COLOR] Range
    [COLOR=#0000ff]Const [/COLOR]YesCol [COLOR=#0000ff]As String[/COLOR] = "O"
   [COLOR=#0000ff] Const [/COLOR]HeaderRow [COLOR=#0000ff]As Long[/COLOR] = 10
    
   [COLOR=#0000ff] Call [/COLOR]UnProtectWorkSheet("[COLOR=#ff0000]YourPasswordHere[/COLOR]")
    
  [COLOR=#0000ff]  Set [/COLOR]Changed = Intersect(Target, Columns(YesCol))
 [COLOR=#0000ff]   If Not [/COLOR]Changed Is Nothing [COLOR=#0000ff]Then[/COLOR]
        Application.EnableEvents =[COLOR=#0000ff] False[/COLOR]
        Application.ScreenUpdating = [COLOR=#0000ff]False[/COLOR]
      [COLOR=#0000ff]  With [/COLOR]Intersect(ActiveSheet.UsedRange, Columns(YesCol), Rows(HeaderRow & ":" & Rows.Count))
            .AutoFilter Field:=1, Criteria1:="=Yes"
        [COLOR=#0000ff]    With[/COLOR] .Offset(1).EntireRow
                .Copy
                LastCellColB = Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Address
             .Copy Destination:=Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .Delete
[COLOR=#0000ff]            End With[/COLOR]
            .AutoFilter
[COLOR=#0000ff]        End With[/COLOR]
        Application.EnableEvents = [COLOR=#0000ff]True[/COLOR]
        Application.ScreenUpdating = [COLOR=#0000ff]True[/COLOR]
[COLOR=#0000ff]    End If[/COLOR]
    
  [COLOR=#0000ff]  Call [/COLOR]ProtectWorkSheet("[COLOR=#ff0000]YourPasswordHere[/COLOR]")
    
[COLOR=#0000ff]End Sub[/COLOR]

[COLOR=#0000ff]Sub [/COLOR]ProtectWorkSheet(myPassword [COLOR=#0000ff]As String[/COLOR])
     ActiveWorkbook.Sheets("REGISTER").Protect Password:=myPassword
[COLOR=#0000ff]End Sub[/COLOR]

[COLOR=#0000ff]Sub[/COLOR] UnProtectWorkSheet(myPassword [COLOR=#0000ff]As String[/COLOR])
     ActiveWorkbook.Sheets("REGISTER").UnProtect Password:=myPassword
[COLOR=#0000ff]End Sub[/COLOR]

 

[cd254]

Thanks again, we're almost there! Now I can add the protection to the sheet, but when I select "Yes" in the column that drives the VBA nothing happens in the first instance, except for removing the auto-filter on the header, I have to select "Yes"again to archive the row, but it then prevents me from putting the auto-filter back onto the header row without first unprotecting the sheet. As my colleagues will need to be able to filter the spreadsheet, but won't have the password for unprotecting the sheet, is there a way to amend the formula above so that it allows the auto-filter to remain on the header row? Thanks again for all your help.

 

[mrmmickle1]

Try putting your cursor on the top line of code:

[COLOR=#0000ff]Call [/COLOR]UnProtectWorkSheet("[COLOR=#ff0000]YourPasswordHere[/COLOR]")

and and hitting F9. This will put a break point in the code. Then try selecting Yes again. When the procedure begins to run it will stop on the line you specified the break point. At this point step through the code one line at a time using the F8 key. Then observe what the code is doing to the worksheet. Where does it go wrong? What is it not doing that you would like it to do? (This should be done with the windows side by side so you can observe what is happening on the worksheet). Once you have observed what the procedure is doing incorrectly it should be easier to diagnose and fix the problem It is hard for me to comprehend what exactly you are trying to accomplish just looking at the code. If you post some sample data of how the "REGISTER" worksheet is set up it may be easier to see what is happening. (I can also test the procedure in a workbook of my own...)

 

[Rockey_01]

Hi,

I have the same request, but I have used another method that I found online. However, the code seem to be not working (but the video shown no problem).
I have 4 drop-down values (OPEN,CLOSED,PENDING & VOID) to archive into 3 different respective sheets. Only "OPEN" status will maintain in the sheet.

The status selection is in column "A" and start from cell "A11"

Application.EnableEvents = False
If Target.Column = 1 And UCase(Target) = "C-PENDING" Then
Cells(Target.Row, Target.Column).EntireRow.Copy Destination:=Sheets("C-PENDNG_ORDER").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Application.EnableEvents = True

 

[mrmmickle1]

Try something like this:

[COLOR=#0000ff]Private Sub[/COLOR] Worksheet_Change([COLOR=#0000ff]ByVal[/COLOR] Target [COLOR=#0000ff]As [/COLOR]Range)
 Application.EnableEvents = [COLOR=#0000ff]False[/COLOR]
       [COLOR=#0000ff] If [/COLOR]Target.Column = 1 And UCase(Target) <> "OPEN" [COLOR=#0000ff]Then[/COLOR]
        Cells(Target.Row, Target.Column).EntireRow.Copy Destination:=Sheets("C-PENDNG_ORDER").Range("A" & Rows.Count).End(xlUp).Offset(1)
[COLOR=#0000ff]        End If[/COLOR]
    Application.EnableEvents = [COLOR=#0000ff]True[/COLOR]
[COLOR=#0000ff]End Sub[/COLOR]

This code has to be pasted in the Worksheet Module that contains the data you are copying. When a cell in column A is altered this Event checks to see what the new value is. If the new value is not "OPEN" then the information is copied and pasted to this worksheet: "C-PENDNG_ORDER"

The <> operator means not equal to. If you only wanted a specific value to be copied and pasted you would change the operator to = If your status column is not A or 1 then change 1 according. 2 = B, 3 = C, etc.

 

[mrsklb]

If I understand your issue correctly maybe you can add this to the code. It will un-protect the worksheet to complete the procedure and then re-protect it after the procedure has run.

 [COLOR=#0000ff] Private Sub [/COLOR]Worksheet_Change([COLOR=#0000ff]ByVal[/COLOR] Target [COLOR=#0000ff]As[/COLOR] Range)  [COLOR=#0000ff]  

    Dim[/COLOR] Changed [COLOR=#0000ff]As[/COLOR] Range
    [COLOR=#0000ff]Const [/COLOR]YesCol [COLOR=#0000ff]As String[/COLOR] = "O"
   [COLOR=#0000ff] Const [/COLOR]HeaderRow [COLOR=#0000ff]As Long[/COLOR] = 10
    
   [COLOR=#0000ff] Call [/COLOR]UnProtectWorkSheet("[COLOR=#ff0000]YourPasswordHere[/COLOR]")
    
  [COLOR=#0000ff]  Set [/COLOR]Changed = Intersect(Target, Columns(YesCol))
 [COLOR=#0000ff]   If Not [/COLOR]Changed Is Nothing [COLOR=#0000ff]Then[/COLOR]
        Application.EnableEvents =[COLOR=#0000ff] False[/COLOR]
        Application.ScreenUpdating = [COLOR=#0000ff]False[/COLOR]
      [COLOR=#0000ff]  With [/COLOR]Intersect(ActiveSheet.UsedRange, Columns(YesCol), Rows(HeaderRow & ":" & Rows.Count))
            .AutoFilter Field:=1, Criteria1:="=Yes"
        [COLOR=#0000ff]    With[/COLOR] .Offset(1).EntireRow
                .Copy
                LastCellColB = Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Address
             .Copy Destination:=Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .Delete
[COLOR=#0000ff]            End With[/COLOR]
            .AutoFilter
[COLOR=#0000ff]        End With[/COLOR]
        Application.EnableEvents = [COLOR=#0000ff]True[/COLOR]
        Application.ScreenUpdating = [COLOR=#0000ff]True[/COLOR]
[COLOR=#0000ff]    End If[/COLOR]
    
  [COLOR=#0000ff]  Call [/COLOR]ProtectWorkSheet("[COLOR=#ff0000]YourPasswordHere[/COLOR]")
    
[COLOR=#0000ff]End Sub[/COLOR]

This is perfect, exactly what I've been looking for.
I've set up a table of accounts, so I can see what's ahead, and on another page, see what's been paid & a calculation as to how many payments have been made per item.

Is there a way to make this reoccuring?

I was thinking the process could be:
1) Check: If payment is Freq is "Once" then just copy the active row to sheet2, and make no further efforts. ELSE, if Freq = Month, Days, Weeks, 6 Monthly, Quarterly or Yearly; continue:
Note: occasionally I have one with a curly frequency: ie first Thursday of the month, 4th Tuesday etc

2) Process with the VBA above (omitting the .delete)
3) Copy the working row to the last row of sheet1, remove the "yes" from the control column (so it doesn't loop through again)
4) Copy date value from A(?) to Z(?), this is now our control value to calculate the next payment "Past Due"
5) Update A(?) to the new date based on the value in "Past Due" and the "Freq" (if Freq=Month, PastDue+1,) etc
6) Delete the first payment, the transaction that triggered the process.

Is that possible??

Thank you in advance.