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

 

[Jeffrey Mahoney]

First of all I wouldn't use Workbook_SheetBeforeDelete. This is relying on the code working properly when a user is trying to delete a sheet.

If you are determined to use that, pleas try this

Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
  Dim wsArchive As Worksheet
  Dim lastRow As Long
  Dim RowLast As Long
  Dim Rng As Range
  Dim OutRng As Range

  ' 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).Offset(1, 0).Row
  '  Determine last row in sheet to be deleted
  RowLast = Sh.Cells(wsArchive.Rows.Count, 1).End(xlUp).Row
  'Set range to copy from deleted sheet
  Set Rng = Sh.Range(Sh.Cells(1, 1), Sh.Cells(RowLast, 1)).EntireRow
  Set OutRng = wsArchive.Range(wsArchive.Cells(lastRow, 1), wsArchive.Cells(lastRow + Rng.Rows.Count - 1, 1)).EntireRow
  
  'Copy the values to the archive
  OutRng.Value = Rng.Value2
  
End Sub

 

[liljunga]

First of all I wouldn't use Workbook_SheetBeforeDelete. This is relying on the code working properly when a user is trying to delete a sheet.

If you are determined to use that, pleas try this

Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
  Dim wsArchive As Worksheet
  Dim lastRow As Long
  Dim RowLast As Long
  Dim Rng As Range
  Dim OutRng As Range

  ' 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).Offset(1, 0).Row
  '  Determine last row in sheet to be deleted
  RowLast = Sh.Cells(wsArchive.Rows.Count, 1).End(xlUp).Row
  'Set range to copy from deleted sheet
  Set Rng = Sh.Range(Sh.Cells(1, 1), Sh.Cells(RowLast, 1)).EntireRow
  Set OutRng = wsArchive.Range(wsArchive.Cells(lastRow, 1), wsArchive.Cells(lastRow + Rng.Rows.Count - 1, 1)).EntireRow
 
  'Copy the values to the archive
  OutRng.Value = Rng.Value2
 
End Sub

Thanks for the reply Jeffrey. This code did not work. And I am not determined to use Workbook_SheetBeforeDelete - If you can write up a different script that will do the same purpose, that is great too!

 

[Jeffrey Mahoney]

How did it not work? Did it give you an error? Did you paste this in the THISWORKBOOK module in VBA? Did you try deleting a sheet tab?

 

[liljunga]

How did it not work? Did it give you an error? Did you paste this in the THISWORKBOOK module in VBA? Did you try deleting a sheet tab?

No error. Just did not transfer over to Archive sheet when I deleted. Yes, it is pasted in THISWORKBOOK. There is only my working sheet (sheet1) and the Archive sheet, so not sure I can delete a sheet tab.

 

[Jeffrey Mahoney]

The code I gave you only works when you try to delete a sheet tab. Create a dummy sheet tab with some numbers in it and then delete it

 

[liljunga]

Ah, I see. I am not trying to delete an entire sheet and have that archived. I maintain a log/tracker daily where when I am "done" with the date, I delete the entire row (not sheet) and I would like the deleted row to be moved to the archive sheet. Do you think you can help me with that?

 

[Jeffrey Mahoney]

Ok, so now were on the right track. This should copy the entire row from the selected cell over to the archive sheet below the last used row

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 = Sht.ActiveCell.EntireRow
  Set OutRng = wsArchive.Cells(lastRow, 1).EntireRow
  
  'Copy the values to the archive
  OutRng.Value = Rng.Value2
  
End Sub

 

[liljunga]

Ok, so now were on the right track. This should copy the entire row from the selected cell over to the archive sheet below the last used row

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 = Sht.ActiveCell.EntireRow
  Set OutRng = wsArchive.Cells(lastRow, 1).EntireRow
 
  'Copy the values to the archive
  OutRng.Value = Rng.Value2
 
End Sub

Ok, so now were on the right track. This should copy the entire row from the selected cell over to the archive sheet below the last used row

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 = Sht.ActiveCell.EntireRow
  Set OutRng = wsArchive.Cells(lastRow, 1).EntireRow
 
  'Copy the values to the archive
  OutRng.Value = Rng.Value2
 
End Sub

Received "Method of data member not found" error

 

[Jeffrey Mahoney]

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