Delete entire row if column has certain text only on specific sheets in workbook

[Plukey]

I have a code that searches Specified sheets Column A for the letter "Y" and copies that row paste to another tab named "CLOSED" I normally go back and manually delete the rows w/ "Y" Im trying to run a code at the end and have a msg box YES/NO to proceed to next code to delete the rows containing Y

Option Explicit
Sub SearchForString()
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
Dim sSheetsWithData As String, sSheetsWithoutData As String
Dim lSheetRowsCopied As Long, lAllRowsCopied As Long
Dim bFound As Boolean
Dim sOutput As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With

WhatFor = ("Y")
If WhatFor = Empty Then Exit Sub

For Each Sheet In Sheets
If Sheet.Name <> "Sheet5" And Sheet.Name <> "" And Sheet.Name <> "sheet6" And Sheet.Name <> "sheet7" And Sheet.Name <> "sheet8" Then
bFound = False
With Sheet.Columns(1)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cell Is Nothing Then
bFound = True
lSheetRowsCopied = 0
FirstAddress = Cell.Address
Do
lSheetRowsCopied = lSheetRowsCopied + 1
Cell.EntireRow.Copy Destination:=Sheets("Closed PS").Range("A" & rows.Count).End(xlUp).Offset(1, 0)
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
Else
bFound = False
End If
If bFound Then
sSheetsWithData = sSheetsWithData & " " & Sheet.Name & " (" & lSheetRowsCopied & ")" & vbLf
lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
Else
sSheetsWithoutData = sSheetsWithoutData & " " & Sheet.Name & vbLf
End If
End With
End If
Next Sheet

If sSheetsWithData <> vbNullString Then
sOutput = "Sheets with data (rows copied)" & vbLf & vbLf & sSheetsWithData & vbLf & _
"Total rows copied = " & lAllRowsCopied & vbLf & vbLf
Else
sOutput = "No sheeTs contained data to be copied" & vbLf & vbLf
End If

If sSheetsWithoutData <> vbNullString Then
sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
Else
sOutput = sOutput & "All sheets had data that was copied."
End If

If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"

With Worksheets("Closed PS")
If .Cells(1, 1).Value = vbNullString Then .rows(1).Delete
End With
Application.EnableEvents = True

Set Cell = Nothing
    If MsgBox("Do you want to run this macro?", vbYesNo, "Decisions, Decisions") = vbYes Then

========================================================================somewhere here run this code  on Sheet1,sheet2,sheet3,sheet4
Sub RunCode()
 Dim lRow As Long
    Dim iCntr As Long
    lRow = 390
    For iCntr = lRow To 1 Step -1
        If Cells(iCntr, 1).Value = "Y" Then
            rows(iCntr).Delete
  

 End If

End Sub

 

[mumps]

Your code looks overly complicated if all you want to do is copy the rows containing "Y" in column A of sheets 1 to 4 to another tab named "CLOSED". Instead of looping you could filter column A on "Y" and copy the filtered range. Try this macro:

Sub SearchForString()
    Application.ScreenUpdating = False
    Dim LastRow As Long, ws As Worksheet, desWS As Worksheet
    Set desWS = Sheets("Closed PS")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each ws In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
        With ws
            .Cells(1, 1).CurrentRegion.AutoFilter 1, "Y"
            .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            .Range("A1").AutoFilter
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub

Do you want to be asked if the copied rows should be deleted in all the four sheets?

 

[Plukey]

Okay, that is much simpler. I like my code because it gives me a report of the tabs & Qty with Y and tabs without. that code works perfect, I just want it to delete the Y's once copied. But, before it deletes msgbox yes/no maybe with a password to proceed, incase a co-worker is pushing buttons and something gets deleted by accident. Attached is what im currently using & know it can be simplified, Sub Loopsheets is on a button. It doesn't take that long since each tab only has max 40 <> lines.

Sub DeleteY()
Dim lRow As Long
Dim iCntr As Long
lRow = 390
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 1).Value = "Y" Then
rows(iCntr).Delete
End If
Next
 End Sub

Sub LoopSheets()
Dim MySheets, i As Long
MySheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
For i = 0 To UBound(MySheets)
Sheets(MySheets(i)).Activate
Call DeleteY
MsgBox "Working on " & ActiveSheet.Name
Next
Worksheets("HOME PAGE").Activate
End Sub

Sub Password()
Dim MyPassword
MyPassword = InputBox("Please enter password", "Password Prompt", "?????")

'hardcode password
If MyPassword = "123" Then
MsgBox "Access Granted", vbInformation, "Access"
Call LoopSheets
Exit Sub
Else
MsgBox "Access denied", vbCritical, "Error"
Exit Sub
End If
End Sub

 

[mumps]

I think that this should do what you want.

Sub SearchForString()
    Application.ScreenUpdating = False
    Dim LastRow As Long, ws As Worksheet, desWS As Worksheet
    Dim sSheetsWithData As String, sSheetsWithoutData As String, sOutput As String
    Dim lSheetRowsCopied As Long, lAllRowsCopied As Long, MyPassword As String
    MyPassword = "123"
    Set desWS = Sheets("Closed PS")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each ws In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
        With ws
            If WorksheetFunction.CountIf(.Range("A:A"), "Y") > 0 Then
                .Cells(1, 1).CurrentRegion.AutoFilter 1, "Y"
                lSheetRowsCopied = .[subtotal(103,A:A)] - 1
                lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
                sSheetsWithData = sSheetsWithData & " " & ws.Name & " (" & lSheetRowsCopied & ")" & vbLf
                .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                .Range("A1").AutoFilter
            Else
                sSheetsWithoutData = sSheetsWithoutData & " " & ws.Name & vbLf
            End If
        End With
    Next ws
    If sSheetsWithData <> vbNullString Then
        sOutput = "Sheets with data (rows copied)" & vbLf & vbLf & sSheetsWithData & vbLf & _
        "Total rows copied = " & lAllRowsCopied & vbLf & vbLf
    Else
        sOutput = "No sheets contained data to be copied" & vbLf & vbLf
    End If
    If sSheetsWithoutData <> vbNullString Then
        sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
    Else
        sOutput = sOutput & "All sheets had data that was copied."
    End If
    If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
    desWS.Rows(1).Delete
    If MsgBox("Do you want to delete all the copied rows?", vbYesNo, "Decisions, Decisions") = vbYes Then
        MyPassword = InputBox("Please enter password", "Password Prompt", "?????")
        If MyPassword = "123" Then
            MsgBox "Access Granted", vbInformation, "Access"
            For Each ws In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
                With ws
                    If WorksheetFunction.CountIf(.Range("A:A"), "Y") > 0 Then
                        .Cells(1, 1).CurrentRegion.AutoFilter 1, "Y"
                        .AutoFilter.Range.Offset(1).EntireRow.Delete
                        .Range("A1").AutoFilter
                        MsgBox "Working on " & ws.Name
                    End If
                End With
            Next ws
        Else
            MsgBox "Invalid password.  Access denied.", vbCritical, "Error"
        End If
    End If
    Sheets("HOME PAGE").Activate
    Application.ScreenUpdating = True
End Sub

 

[Plukey]

WOW! Absolutely perfect...I did get error variable not set, I removed filter from my tabs and it worked...not sure what was goin on there.

 

[mumps]

Glad it worked out.

 

[Plukey]

Just got the error again, thought it was the filter, its only on two of the sheets...if I remove the Y manually on those two sheets it works ,. Is it something with the table maybe?

 

[Plukey]

Think I figured it out the two sheets were down to one line in the table, once I pulled down more lines in the table the error's stopped...is there a work around so I don't have to keep adding lines to the tables.

 

[mumps]

the two sheets were down to one line in the table, once I pulled down more lines in the table

I'm not sure what you mean by this. By "one line" do you mean just the headers in row 1 or one line of data? Also, please explain "once I pulled down more lines".

 

[Plukey]

Once I converted it from a table to range it works. It would get stuck somewhere around here

(.AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
.Range("A1").AutoFilter

===(error variable not set)

Im okay with it not being a table
Only reason I made each sheet a table was because of this code.. Column B needs to be sorted but, it changed the color back to white every time.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("B:B")) Is Nothing Then
Range("B1").Sort Key1:=Range("B2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=True, _
Orientation:=xlTopToBottom
End If
End Sub