Code to Copy/Paste based on Criteria

[jhedges]

I have two worksheets one titled "PL dbase" and the other "waiting list" in the same workbook. I would like the below code, to trim the last entry(ies) from the active sheet. Right now it trims entries from all the sheets. Could someone help me determine how to adjust this code to accomplish this?

Sub TrimAllSheets()
 
    Dim cs As String
    cs = ActiveSheet.Name
    Dim y As Integer
    y = Application.InputBox("How many bottom rows do you wish to delete?", _
    Default:=1, Type:=1) 'Change default number (3) if desired.
    If MsgBox("Are you sure you wish to delete " & y & " rows from the bottom of ALL sheets?", _
    vbYesNo, "Trim ALL Sheets") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    Dim r As Range, s As Range
    Dim ws As Worksheet
    On Error Resume Next 'Error handler
    For Each ws In ThisWorkbook.Worksheets
        ws.Activate
        Set r = ActiveSheet.Range("A65536").End(xlUp).Offset(-y + 1)
        Set s = ActiveSheet.Range("A65536").End(xlUp)
        If ActiveCell.Row < 10 Then GoTo circumv 'Not to delete Headers
        Range(r, s).EntireRow.Delete
circumv:
    Next ws
    Sheets(cs).Activate
    Application.ScreenUpdating = True
 
End Sub

 

[Jaye7]

Hi,

I am not an expert, but the following works if the last cell value in your range of column A is less than 10.

Give it a go on a non-important test sheet.

Sub TrimAllSheets()
 
 
    Dim y As Integer
    y = Application.InputBox("How many bottom rows do you wish to delete?", _
    Default:=1, Type:=1) 'Change default number (3) if desired.
    If MsgBox("Are you sure you wish to delete " & y & " rows from the bottom of ALL sheets?", _
    vbYesNo, "Trim Active sheet") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    Dim r As Range, s As Range
    Dim activesheet As Worksheet
    'On Error Resume Next 'Error handler
    With activesheet
        Range("A65536").Select
        Range(Selection, Selection.End(xlUp)).Select
        ActiveCell.Select
        ActiveCell.Offset(-y + 1).Activate
 
        If ActiveCell.Row < 10 Then GoTo circumv 'Not to delete Headers
        Dim CurRow As Integer, CurCol As Integer, intCount1 As Long
 
 
    CurRow = ActiveCell.Row
 
    Range("a" & CurRow).Delete
 
 
 
        End With
circumv:
 
    Application.ScreenUpdating = True
 
End Sub