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]

Ok, I'm altering the code. I'm going to make it so a user can select non-contiguous rows, like row 3, 5, 10. Give me 10

 

[Jeffrey Mahoney]

OK, this is working for me. It assumes that column A must have something in it. If there are any blanks in Column A, I'll have to alter the code to find the last used row a better way

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

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

Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'Set range to copy from deleted sheet
Set Rng = Selection.EntireRow
For Each aRng In Rng.Areas
Set OutRng = wsArchive.Cells(wsArchive.Rows.Count, 1).End(xlUp).Offset(1, 0)
Set OutRng = wsArchive.Range(OutRng, OutRng.Offset(aRng.Rows.Count - 1, aRng.Columns.Count - 1))
OutRng.Value = aRng.Value2
Next aRng

Rng.Delete

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

 

[Jeffrey Mahoney]

Select any row or rows and run the macro. You'll probably want to create a button to run this.

 

[liljunga]

OK, this is working for me. It assumes that column A must have something in it. If there are any blanks in Column A, I'll have to alter the code to find the last used row a better way

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

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

Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'Set range to copy from deleted sheet
Set Rng = Selection.EntireRow
For Each aRng In Rng.Areas
Set OutRng = wsArchive.Cells(wsArchive.Rows.Count, 1).End(xlUp).Offset(1, 0)
Set OutRng = wsArchive.Range(OutRng, OutRng.Offset(aRng.Rows.Count - 1, aRng.Columns.Count - 1))
OutRng.Value = aRng.Value2
Next aRng

Rng.Delete

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

This is deleting the row I intend to and the row below it (unintentionally). This is the 2nd or 3rd script I have used that has done this. If it is working for you, I assume there is something wrong with my excel

 

[Jeffrey Mahoney]

I tested again on my end and it is working. Just for fun, try this: Turn this off in Excel Options

 

[Jeffrey Mahoney]

No, that shouldn't affect it

 

[Jeffrey Mahoney]

You have a macro that you posted that is probably still running. Go find that old code in THISWORKBOOK

 

[Jeffrey Mahoney]

Stop any Event based macro for now. Find the Subs that have PRIVATE before them

 

[liljunga]

Got it. Now it is working when I run the macro. Is there a way I can have it automatically run when I manually delete the row, or if I had the row selected I could press a shortcut to get the macro to run?

 

[Jeffrey Mahoney]

As we spoke before, it doesn't know when somebody intends to insert or delete a row.

Create a macro button. Developer > Insert > ActiveX Command Button. Draw it on the screen. Right click and choose View Code. Add "ArchiveRow" in between the 2 lines.