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

 

[DanteAmor]

Try this:

Option Explicit
Sub SearchForString_2()
    Dim WhatFor As String, sSheetsWithData As String, sOutput As String
    Dim sh As Worksheet, sh2  As Worksheet
    Dim pRow As Long, sRow As Long, Counter As Long
    
    Application.ScreenUpdating = False
    Set sh2 = Sheets("Closed PS")
    pRow = sh2.Range("A" & Rows.Count).End(xlUp).Row
    
    WhatFor = "Y"
    If WhatFor = Empty Then Exit Sub
    
    For Each sh In Sheets
        Select Case sh.Name
            Case "HOMEPAGE", "Other", "Closed PS", "Backlog to Research", "Pre-Scrap"
            Case Else
            If sh.AutoFilterMode Then sh.AutoFilterMode = False
            sh.Range("A1:A" & sh.Range("A" & Rows.Count).End(xlUp).Row).AutoFilter 1, WhatFor
            sRow = sh.Range("A" & Rows.Count).End(xlUp).Row
            If sRow > 1 Then
                Counter = sh.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Count - 1
                sSheetsWithData = sSheetsWithData & "    " & sh.Name & " (" & Counter & ")" & vbLf
                sh.AutoFilter.Range.Offset(1).EntireRow.Copy sh2.Range("A" & Rows.Count).End(xlUp)(2)
                sh.AutoFilter.Range.Offset(1).EntireRow.Delete
            End If
            If sh.AutoFilterMode Then sh.AutoFilterMode = False
        End Select
    Next
    If sSheetsWithData <> vbNullString Then
        sOutput = "Sheets with data (rows copied)" & vbLf & vbLf & sSheetsWithData & vbLf & _
            "Total rows copied = " & sh2.Range("A" & Rows.Count).End(xlUp).Row - pRow & vbLf & vbLf
    Else
        sOutput = "No sheets contained data to be copied" & vbLf & vbLf
    End If
    MsgBox sOutput, vbInformation, "Copy Report"
End Sub

 

[Plukey]

Its giving Object Variable or with block Variable not set & It hides the Rows that don't have "Y"

 

[DanteAmor]

Send an error?
What does the error say and in which line does it stop?

 

[Plukey]

It says.... Object variable or With block variable not set" and Hides rows without "Y"
it doesn't select where the line stopped....

 

[DanteAmor]

The idea of ​​the macro is to filter and leave only "Y" records visible, copy them and delete them.

Ok change strategy and I send you the updated macro, give me a few minutes.

 

[Plukey]

Okay, sorry for any miscommunication, I want it to delete the "Y"'s after they paste to "Closed PS" but also, warn the user before they do.
Currently itll paste the rows w/ "Y" but then I have to manually delete the rows. As this WB is not one that I view daily .

 

[DanteAmor]

Sorry about confusion, I went back to your original macro and I adapted an object to delete the rows

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 "HOMEPAGE", "Other", "Closed PS", "Backlog to Research", "Pre-Scrap"
            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)
                    
[COLOR=#0000ff]                    If rdel Is Nothing Then[/COLOR]
[COLOR=#0000ff]                        Set rdel = b[/COLOR]
[COLOR=#0000ff]                    Else[/COLOR]
[COLOR=#0000ff]                        Set rdel = Union(rdel, b)[/COLOR]
[COLOR=#0000ff]                    End If[/COLOR]
                    
                    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.ScreenUpdating = True
    
    MsgBox sOutput, vbInformation, "Copy Report"
End Sub

Let me know if you have any doubt.

 

[Plukey]

Now its stopping at my SheetChange code at the 9th line

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
 Dim ws As Worksheet, Dn As Range, Q As Variant
 With CreateObject("scripting.dictionary")
 .CompareMode = vbTextCompare
Application.ScreenUpdating = False
 For Each ws In Worksheets
If ws.Name <> "HOMEPAGE" And ws.Name <> "Other" And ws.Name <> "Closed PS" And ws.Name <> "Backlog to Research" And ws.Name <> "Pre-Scrap" Then
    ws.Tab.ColorIndex = xlColorIndexNone '<<<
    ws.Range("B2:B106").Interior.ColorIndex = xlNone   <<<<-----------------------
        For Each Dn In ws.Range("B2:B106")
            If Dn.Value <> "" Then
                If Not .exists(Dn.Value) Then
                    .Add Dn.Value, Array(Dn, ws)
                Else
                    Q = .Item(Dn.Value)
                        Q(0).Interior.Color = vbRed
                        Dn.Interior.Color = vbRed
                        ws.Tab.Color = 225
                        Q(1).Tab.Color = 225
                    .Item(Dn.Value) = Q
                    End If
                End If
            Next Dn
        End If
 Next ws
 
Application.ScreenUpdating = True '<<<
End With
End Sub

 

[DanteAmor]

Ok, I do not know the macro, but maybe it has problems because you're deleting rows, maybe it's filling up the stack and showing the error, by the way, what does the error say?


You could deactivate your event and try the macro that I sent you.