Help in selecting and copying filtered data (Could not select single entry)

[Gaurangg]

Hi Friends,

I have build a code to select the filtered data to copy and paste into another worksheet. However there is an issue with it. When there is only one entry found from filtered data, it throws an error coz it selects the data till last row of the sheet. Kindly help me to correct the code so I can select the data irrespective of single entry or multiple entry.

Sheet2.Select
    If Sheet2.Range("P1").Value = 0 Then
    MsgBox "There is no unique data found from this file." & vbNewLine & vbNewLine & "Please check the file you have selected." & vbNewLine & vbNewLine & "Thank You", vbOKOnly + vbInformation, "New Request Tool"
    
    Sheet2.Range("A:Z").Select
    Selection.EntireColumn.Delete
    Range("A1").Select
    Sheet2.Select
    Sheet2.Protect Password:="Paasword1"
    Sheet3.Select
    Sheet3.Protect Password:="Paasword2"
    Sheet1.Select
    Range("A50").Select
    
    Sheet2.Visible = xlSheetVeryHidden
    Sheet3.Visible = xlSheetVeryHidden
    Sheet4.Visible = xlSheetVeryHidden
    
    ActiveWorkbook.Save
        
    Exit Sub
    Else
    Sheet2.Select
    Range("A1:O1").AutoFilter
    NewRng = Sheet2.Range("B1048576").End(xlUp).Row
    Range("O1").Select
    Range("$A$1:$O" & NewRng).AutoFilter Field:=15, Criteria1:="True"
    Range("M1").Select
    Range("$A$1:$O" & NewRng).AutoFilter Field:=13, Criteria1:="15"
    Range("K1").Select
    Range("$A$1:$O" & NewRng).AutoFilter Field:=11, Criteria1:="No"
    
    Range("A1:L" & NewRng).Select
    ActiveCell.Offset(1, 0).Select
    Do Until ActiveCell.EntireRow.Hidden = False
        ActiveCell.Offset(1, 0).Select
    Loop
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    
    Selection.Copy
    
'Here where the data to be pasted
    Sheet3.Select
    LSTRw = Sheet3.Range("A1048576").End(xlUp).Row
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

 

[DanteAmor]

Try this:

Sub test1()
    Sheet2.Select
    If Sheet2.Range("P1").Value = 0 Then
        MsgBox "There is no unique data found from this file." & vbNewLine & vbNewLine & "Please check the file you have selected." & vbNewLine & vbNewLine & "Thank You", vbOKOnly + vbInformation, "New Request Tool"
        
        Sheet2.Range("A:Z").Select
        Selection.EntireColumn.Delete
        Range("A1").Select
        Sheet2.Select
        Sheet2.Protect Password:="Paasword1"
        Sheet3.Select
        Sheet3.Protect Password:="Paasword2"
        sheet1.Select
        Range("A50").Select
        
        Sheet2.Visible = xlSheetVeryHidden
        Sheet3.Visible = xlSheetVeryHidden
        sheet4.Visible = xlSheetVeryHidden
        
        ActiveWorkbook.Save
        
        Exit Sub
    Else
        'Sheet2.Select
        Range("A1:O1").AutoFilter
        NewRng = Sheet2.Range("B1048576").End(xlUp).Row
        Range("$A$1:$O" & NewRng).AutoFilter Field:=15, Criteria1:="True"
        Range("$A$1:$O" & NewRng).AutoFilter Field:=13, Criteria1:="15"
        Range("$A$1:$O" & NewRng).AutoFilter Field:=11, Criteria1:="No"
        
        'Columns to copy
        Range("A1:O" & NewRng).Copy
        
        'Here where the data to be pasted
        Sheet3.Select
        LSTRw = Sheet3.Range("A1048576").End(xlUp).Row
        Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    End If
End Sub