Auto-Archive deleted Rows in Excel

[liljunga]

Hello, I'm trying to create a VBA script in Excel that moves deleted rows to an 'Archive' sheet when users right-click and delete entire rows. I've tried the following code, but it's not working as expected. When I right-click and delete rows, they are not moving to the 'Archive' sheet. Could someone please help me troubleshoot this issue? Or can someone provide me new code to test out?

Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object, ByVal Target As Range)
Dim wsArchive As Worksheet
Dim lastRow As Long

' Name of your Archive sheet
Set wsArchive = ThisWorkbook.Sheets("Archive")

' Determine the last row in the archive sheet
lastRow = wsArchive.Cells(wsArchive.Rows.Count, 1).End(xlUp).Row

' Copy the deleted rows to the archive sheet
Target.EntireRow.Copy wsArchive.Rows(lastRow + 1)

' Clear the deleted rows from the original sheet
Application.EnableEvents = False
Target.EntireRow.Delete
Application.EnableEvents = True
End Sub

 

[liljunga]

I changed one minor thing

Sub ArchiveRow()
  Dim wsArchive As Worksheet
  Dim lastRow As Long
  Dim Rng As Range
  Dim OutRng As Range
  Dim Sht As Worksheet

  ' Name of your Archive sheet
  Set wsArchive = ThisWorkbook.Sheets("Archive")
  Set Sht = ActiveSheet

  ' Determine the last row in the archive sheet
  lastRow = wsArchive.Cells(wsArchive.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
 
  'Set range to copy from deleted sheet
  Set Rng = ActiveCell.EntireRow
  Set OutRng = wsArchive.Cells(lastRow, 1).EntireRow
 
  'Copy the values to the archive
  OutRng.Value = Rng.Value2
 
End Sub

This is still not working for me. Not transferring over when I delete a row

 

[liljunga]

I changed one minor thing

Sub ArchiveRow()
  Dim wsArchive As Worksheet
  Dim lastRow As Long
  Dim Rng As Range
  Dim OutRng As Range
  Dim Sht As Worksheet

  ' Name of your Archive sheet
  Set wsArchive = ThisWorkbook.Sheets("Archive")
  Set Sht = ActiveSheet

  ' Determine the last row in the archive sheet
  lastRow = wsArchive.Cells(wsArchive.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
 
  'Set range to copy from deleted sheet
  Set Rng = ActiveCell.EntireRow
  Set OutRng = wsArchive.Cells(lastRow, 1).EntireRow
 
  'Copy the values to the archive
  OutRng.Value = Rng.Value2
 
End Sub

This did no work. It is not transferring to archive sheet when I delete a row.

 

[Jeffrey Mahoney]

The code was designed to run anytime you needed. I'm changing it, hold on.

 

[Jeffrey Mahoney]

So, here's the issue. There's not actually an event that will catch cells while they are being deleted. There is an event that will catch changes. The question is, how do we filter out cell changes and edits along with just a few cell deletions here and there.

 

[Jeffrey Mahoney]

This event triggers even when a new row is added which really dirty's the water

 

[liljunga]

If it is not possible, would changing the action that triggers it from deleting the row to, for example, putting a "1" in a specific cell make a difference? Instead of deleting the row to trigger the transfer of the row to the archive sheet, I could fill in a cell on the row and when that cell is filled it, then it would take the entire row and remove it and copy it over to the archive sheet. Would that be easier?

 

[Jeffrey Mahoney]

OK, this is not going to work. The Change or SheetChange events don't work before the deletion, they run after. So no data can be copied prior to deletion

 

[Jeffrey Mahoney]

Yes, adding something to a row like a 1 or D or a checkbox would be a good trigger to delete a row. Although, if your going to do that, why no allow the user to select the rows they want to delete and run a macro to copy the data to the Archive and then delete the rows they selected?

 

[liljunga]

OK, this is not going to work. The Change or SheetChange events don't work before the deletion, they run after. So no data can be copied prior to deletion

The following code works transfers over the row, but also deletes the row below my intended deleted row. I.E. I delete row 2 and it automatically deletes row 2 and row 3 and transfers over row 3.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim Archive As Worksheet
Dim cell As Range
Dim lastRow As Long

Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your original sheet
Set Archive = ThisWorkbook.Sheets("Archive") ' Change "Archive" to the name of your archive sheet

Application.EnableEvents = False

If Not Intersect(Target, ws.Columns(1)) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
lastRow = Archive.Cells(Archive.Rows.Count, "A").End(xlUp).Row
ws.Rows(cell.Row).Copy Archive.Rows(lastRow + 1)
ws.Rows(cell.Row).Delete
Exit For ' Exit the loop after the first deletion
End If
Next cell
End If

Application.EnableEvents = True
End Sub

 

[liljunga]

Yes, adding something to a row like a 1 or D or a checkbox would be a good trigger to delete a row. Although, if your going to do that, why no allow the user to select the rows they want to delete and run a macro to copy the data to the Archive and then delete the rows they selected?

Yes, how would I do this - "why no allow the user to select the rows they want to delete and run a macro to copy the data to the Archive and then delete the rows they selected?"