I need a way of undoing a macro that deletes all lines

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,392
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a spreadsheet with a table that is used for storing quotes that has a delete all table lines button. My supervisor needs a way to undo or restore if the delete all lines button is clicked. The quote could be up to 100 pages long, so re-entering all that information is just not practical. Can someone give me some ideas on how I could achieve this please as I thought of possibly saving a copy of the file before the delete all lines code is run but there may be a better way of doing this?


Here is the delete all lines code:
Code:
Sub cmdDeleteAllQuoteLines()
    'Deleting The Data In A Table
    Dim tbl As ListObject
    Dim cell As Range
    
    Set tbl = Sheets("NPSS_quote_sheet").ListObjects("npss_quote")
    'Delete all table rows except first row
    With tbl.DataBodyRange
        If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete

        End If
        'Clear the contents, but not delete the formulas
        For Each cell In tbl.ListRows(1).Range.Cells
            If Not cell.HasFormula Then
                cell.Value = ""
            End If
        Next
    End With
        With ThisWorkbook.Worksheets("NPSS_quote_sheet")
            .ListObjects("npss_quote").DataBodyRange.Columns(13).Value = 1 - 0.1 * ActiveSheet.chkIncrease.Value
            .Rows(11).Font.Bold = False
        End With
    
    'ListObjects("NPSS_quote").ListColumns("10%Increase").DataBodyRange.Value = "1"
End Sub

Thanks,
Dave
 
But I don't want it to add to a new sheet called backup and exit if the sheet exists. I want to paste over the contents of the backup sheet.
 
Last edited:
Upvote 0

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
This should be well within your pay grade Dave !

I'd suggest manually making a copy of the sheet called "NPSS_quote_sheet" rename it "Backup". Then delete the rows from the Backup sheet up to the header.
Then when running the delete lines macro ONLY copy the range from below the headers to the last row, across to the backup sheet
Remember the macro recorder is your friend !
 
Upvote 0
I tried to modify this code but I didn't work. I copied the sheet and then tried to update the references in the code but nothing would happen when I run this code to backup the entries. Is there something wrong with my code? For anyone else looking at this, I am just trying to copy all rows in my table npss_quote that is within my sheet NPSS_quote_sheet to a table called npss_quote_backup that is within my sheet Backup. If anyone else is looking at this, I am trying to copy all rows from a table called npss_quote in the sheet, NPSS_quote_sheet to a table called npss_quote_backup that is stored within the sheet Backup.

Code:
Private Sub cmdBackup_Click()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim desWS As Worksheet, srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet")
        Set desWS = ThisWorkbook.Sheets("Backup")
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, x As Long, header As Range
        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
        lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    With srcWS.Range("A:A,B:B,D:D,F:F,G:G,H:H")
        If lastRow2 < 5 Then
            lastRow2 = 5
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 11 Then
                    desWS.ListObjects.Item("npss_quote_backup").ListRows.Add
                    .ListObjects.Item("npss_quote_backup").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"
                End If
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else
            lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            desWS.ListObjects.Item("npss_quote_backup").ListRows.Add
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    desWS.ListObjects("npss_quote_backup").Sort.SortFields.Clear
    desWS.ListObjects("npss_quote_backup").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("npss_quote_backup").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    
    With Application
        .CutCopyMode = False
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Dim oLst As ListObject
        Dim lr As Long, rng As Range
        lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lr To 4 Step -1
            Set rng = desWS.Cells(i, 1)
            If WorksheetFunction.CountBlank(rng) = 1 Then
                desWS.Rows(i).Delete
            End If
        Next i
End Sub

Thanks guys
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,743
Messages
6,180,687
Members
452,994
Latest member
Janick

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top