Few more Adjusments Wanted

[Plukey]

Below, Once the button is activated...it searches for "Y" in "A2:A" in all worksheets specified. It means that line is closed... Someone will enter a Y for yes Its Closed and transfer to Sheet "Closed PS" (This Person is not familiar with PC concepts) So we have to be gentle . A quick report is given ..Who - how many / & who -doesn't. I would like it to delete the original source and prompt within the preview box (Yes/Transfer & Delete) - (No Exit), basically... I can change the verbiage if need be. Currently, it just gives the preview and I have to delete original source manually.
I made it a button because they would get overwhelmed if It happened instantly with SheetChanged ..Advise welcomed please!

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") <<<'I used to have a msg box..but decided not to, because it will always be Y'<<<
    If WhatFor = Empty Then Exit Sub
    
    For Each Sheet In Sheets
        If Sheet.Name <> "HOMEPAGE" And Sheet.Name <> "Other" And Sheet.Name <> "Closed PS" And Sheet.Name <> "Backlog to Research" And Sheet.Name <> "Pre-Scrap" 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
    
    
End Sub

 

[Plukey]

I started over... and exited entered revised code and its working perfect! its the little things that makes this what it is. thank you!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[Plukey]

Thank you!

 

[Plukey]

I'm at work ans applied the code to original workbook and I'm getting vba-400 error. I checked for hidden sheets. It only copies from 1 out of the 7 Tab/sheets that have "Y" in column A throws code and doesn't delete either.
Any Ideas???

 

[DanteAmor]

You have hidden or protected sheets. You have merged cells.
Exactly what does the error say?
In which row of the macro does it stop?
Something unusual that you observe in the sheet where the macro stopped?

 

[Plukey]

You have hidden or protected sheets. You have merged cells.
Exactly what does the error say?
In which row of the macro does it stop?
Something unusual that you observe in the sheet where the macro stopped?

It stops after copying the first sheet and throws the 400 Visual Basics Application. I un-protected the original and looked for hidden sheets. I'll take another look .. It works perfect on the copy version. I'm leaving work but will pick back up at home in a few. Alo, I'm not sure at what point it stops in the code

 

[DanteAmor]

Try to execute the code step by step with F8 to see when it stops, that way you identify the sheet, the code and if there is any detail with the records of the sheet

 

[Plukey]

Try to execute the code step by step with F8 to see when it stops, that way you identify the sheet, the code and if there is any detail with the records of the sheet

Stay tuned, I’m not getting the errors at home with the practice workbook. We’ll pick back up in the morning.

 

[DanteAmor]

ok.
Let me know if you have some doubt

 

[Plukey]

I made a copy of the original Workbook and run the code...It stops at the end of first sheet, and says (error 400 Microsoft VBA ) I've checked for hidden sheets & locked cells. Same thing when I run line by F8 ..

Option Explicit
Sub SearchForString_2()
    Dim WhatFor As String, sSheetsWithData As String, sSheetsWithoutData As String, sOutput As String, FirstAddress As String
    Dim sh As Worksheet, sh2  As Worksheet
    Dim lSheetRowsCopied As Long, lAllRowsCopied As Long
    Dim r As Range, b As Range, rdel As Range
    Dim bFound As Boolean
    
    Application.ScreenUpdating = False
    Set sh2 = Sheets("Closed PS")
    
    WhatFor = "Y"
    If WhatFor = Empty Then Exit Sub
    
    For Each sh In Sheets
        Select Case sh.Name
            Case "HOME PAGE", "Backlog to Research", "Pre-Scrap", "Other", "Closed PS"
            Case Else
            
            bFound = False
            Set rdel = Nothing
            Set r = sh.Range("A:A")
            Set b = r.Find(WhatFor, LookAt:=xlWhole, LookIn:=xlValues)
            If Not b Is Nothing Then
                FirstAddress = b.Address
                bFound = True
                lSheetRowsCopied = 0
                Do
                    lSheetRowsCopied = lSheetRowsCopied + 1
                    b.EntireRow.Copy sh2.Range("A" & rows.Count).End(xlUp)(2)
                    
                    If rdel Is Nothing Then
                        Set rdel = b
                    Else
                        Set rdel = Union(rdel, b)
                    End If
                    
                    Set b = r.FindNext(b)
                Loop While Not b Is Nothing And b.Address <> FirstAddress
            End If
            If bFound Then
                sSheetsWithData = sSheetsWithData & "    " & sh.Name & " (" & lSheetRowsCopied & ")" & vbLf
                lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
                rdel.EntireRow.Delete
            Else
                sSheetsWithoutData = sSheetsWithoutData & "    " & sh.Name & vbLf
            End If
        End Select
    Next
    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
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox sOutput, vbInformation, "Copy Report"
End Sub