Thanks Thanks:  0
Likes Likes:  0
Page 1 of 4 123 ... LastLast
Results 1 to 10 of 33

Thread: Few more Adjusments Wanted

  1. #1
    New Member
    Join Date
    Apr 2019
    Posts
    32
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Few more Adjusments Wanted

    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!

    Code:
    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

  2. #2
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    3,198
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    9 Thread(s)

    Default Re: Few more Adjusments Wanted

    Try this:

    Code:
    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
    Regards Dante Amor

  3. #3
    New Member
    Join Date
    Apr 2019
    Posts
    32
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Few more Adjusments Wanted

    Its giving Object Variable or with block Variable not set & It hides the Rows that don't have "Y"
    Last edited by Plukey; Apr 20th, 2019 at 09:23 PM.

  4. #4
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    3,198
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    9 Thread(s)

    Default Re: Few more Adjusments Wanted

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

  5. #5
    New Member
    Join Date
    Apr 2019
    Posts
    32
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Few more Adjusments Wanted

    It says.... Object variable or With block variable not set" and Hides rows without "Y"
    it doesn't select where the line stopped....
    Last edited by Plukey; Apr 21st, 2019 at 03:13 PM.

  6. #6
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    3,198
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    9 Thread(s)

    Default Re: Few more Adjusments Wanted

    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.
    Regards Dante Amor

  7. #7
    New Member
    Join Date
    Apr 2019
    Posts
    32
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Few more Adjusments Wanted

    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 .
    Last edited by Plukey; Apr 21st, 2019 at 03:41 PM.

  8. #8
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    3,198
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    9 Thread(s)

    Default Re: Few more Adjusments Wanted

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


    Code:
    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)
                        
                        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.ScreenUpdating = True
        
        MsgBox sOutput, vbInformation, "Copy Report"
    End Sub
    Let me know if you have any doubt.
    Regards Dante Amor

  9. #9
    New Member
    Join Date
    Apr 2019
    Posts
    32
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Few more Adjusments Wanted

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

    Code:
    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

  10. #10
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    3,198
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    9 Thread(s)

    Default Re: Few more Adjusments Wanted

    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.
    Regards Dante Amor

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •