Page 1 of 2 12 LastLast
Results 1 to 10 of 15

Thread: Another day another wrinkle- Choose last instance of phrase and delete rest of rows
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Mar 2010
    Location
    New England
    Posts
    414
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    My latest quandary,

    My file I copy to draw data from is data run everyday. The file runs a new instance anytime anything is added and a row is added with all the data plus the additional information.
    The file is at 95,500 rows right now .
    I am trying to parse by ID, then by status,and then by step.

    My problem is I have 5 worksheets pulling for their information when called. I am trying to find a way to minimize the time (over 15 minutes to run this).

    Can anyone help me figure out if parsing to the last line fitting the three criteria above would limit the data searched if I deleted all the previous instances as I paste to the workbook or if there is a faster way to run the code as it stands now?

    Here is a subset of the code that repeats for 5 different worksheets:
    Code:
    Sub Defie()
    
    
        Dim LastRow As Long, SecondRow As Long
        Dim i As Long, j As Long
        Dim First As String, Second As String
        'used by/for dictionary
        Dim lr As Long, X As Long
        Dim dic As Object
        Dim arr As Variant, key As Variant
    
    
            'load dictionary with Uniques From Column A
            With Sheets("IQP")
                lr = .Range("A" & .Rows.Count).End(xlUp).Row
                arr = .Range("A2:A" & lr)
            End With
            Set dic = CreateObject("Scripting.Dictionary")
            For X = 1 To UBound(arr, 1)
              dic(arr(X, 1)) = 1
            Next X
            
            Application.ScreenUpdating = False
            
                LastRow = Sheets("IQP").Cells(Rows.Count, "A").End(xlUp).Row
                SecondRow = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
                i = 1 + LastRow
                j = 1 + SecondRow
                
                First = "Investigate Complaint"
                Second = "Review Product History"
                
            For Each key In dic.keys
                With Sheets("IQP")
                    For i = LastRow To 1 Step -1    'work from the bottom up
                        If .Cells(i, 1) = key And .Cells(i, 2) = "INWORKS" And _
                                .Cells(i, 27) <> "CLS" And .Cells(i, 20) <> "" And Trim(.Cells(i, 11)) = "" Then
                            If .Cells(i, 26) = First Or .Cells(i, 26) = Second Then
                                 Sheets("Sheet1").Cells(j, 1) = Format(Now(), "DD-MMM-YYYY")
                                 'Complaint ID
                                 Sheets("Sheet1").Cells(j, 2) = .Cells(i, 1).Value
                                 'Assigned to Name
                                 Sheets("Sheet1").Cells(j, 3) = .Cells(i, 3).Value
                                 'Aware Date
                                 Sheets("Sheet1").Cells(j, 4) = .Cells(i, 9).Value
                                 '(Initiation)Date Assigned to CI
                                 Sheets("Sheet1").Cells(j, 5) = .Cells(i, 20).Value
                                 'BTK Name
                                 Sheets("Sheet1").Cells(j, 6) = .Cells(i, 26).Value
                                 'Product
                                 Sheets("Sheet1").Cells(j, 7) = .Cells(i, 4).Value
                                 'Summary
                                 Sheets("Sheet1").Cells(j, 8) = .Cells(i, 6).Value
                                 'Severity
                                 Sheets("Sheet1").Cells(j, 9) = .Cells(i, 19).Value
                                 'Serial Number
                                 Sheets("Sheet1").Cells(j, 10) = .Cells(i, 8).Value
                                 j = j + 1
                                 Exit For
                            End If
                        End If
                    Next i
                End With
            Next key
    
    
    Application.ScreenUpdating = True
    
    
    End Sub
    Help, please...

    DThib
    Last edited by DThib; Sep 9th, 2019 at 03:24 PM.

  2. #2
    Board Regular
    Join Date
    Mar 2010
    Location
    New England
    Posts
    414
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    Addendum to above question:

    I have tried this I have included below.
    It only pulls the data on the first logic statement Sheets("Sheet1"). It takes 20 minutes.

    Help!
    Code:
    Public Sub Big_One()
    
    
        Dim LastRow As Long, SecondRow As Long, ThirdRow As Long, FourthRow As Long, FifthRow As Long, SixthRow As Long
        Dim i As Long, j As Long, k As Long, m As Long, n As Long, o As Long
        Dim First As String, Second As String, Third As String, Fourth As String
        Dim Fifth As String, Sixth As String, Seventh As String, Eighth As String, Ninth As String
     
       'used by/for dictionary
         Dim lr As Long, X As Long
         Dim dic As Object
         Dim arr As Variant, key As Variant
    
    
         Application.ScreenUpdating = False
        
            'load dictionary with Uniques From Column A
             With Sheets("Initial Query Pull")
                 lr = .Range("A" & .Rows.Count).End(xlUp).Row
                 arr = .Range("A2:A" & lr)
             End With
            Set dic = CreateObject("Scripting.Dictionary")
            For X = 1 To UBound(arr, 1)
               dic(arr(X, 1)) = 1
            Next X
             
            LastRow = Sheets("Initial Query Pull").Cells(Rows.Count, "A").End(xlUp).Row
            SecondRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
            ThirdRow = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
            FourthRow = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
            FifthRow = Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Row
            SixthRow = Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Row
    
    
            i = 1 + LastRow
            j = 1 + SecondRow
            k = 1 + ThirdRow
            m = 1 + FourthRow
            n = 1 + FifthRow
            o = 1 + SixthRow
    
    
    
    
            First = "Investigate Complaint"
            Second = "Review Product History"
            Third = "Decontaminate Product"
            Fourth = "Sample Management"
            Fifth = "Evaluate Product"
            Sixth = "Adhoc"
            Seventh = "Approve Product Evaluation"
            Eighth = "Approve Product History"
            Ninth = "Approve Complaint Investigation"
                
            For Each key In dic.keys
                With Sheets("Initial Query Pull")
                    For i = LastRow To 1 Step -1    'work from the bottom up
                        If .Cells(i, 1) = key And .Cells(i, 2) = "INWORKS" And _
                                .Cells(i, 27) <> "CLS" And .Cells(i, 20) <> "" And Trim(.Cells(i, 11)) = "" Then
                            If .Cells(i, 26) = First Or .Cells(i, 26) = Second Then
                                 Sheets("Sheet1").Cells(j, 1) = Format(Now(), "DD-MMM-YYYY")
                                 'Complaint ID
                                 Sheets("Sheet1").Cells(j, 2) = .Cells(i, 1).Value
                                 'Assigned to Name
                                 Sheets("Sheet1").Cells(j, 3) = .Cells(i, 3).Value
                                 'Aware Date
                                 Sheets("Sheet1").Cells(j, 4) = .Cells(i, 9).Value
                                 '(Initiation)Date Assigned to CI
                                 Sheets("Sheet1").Cells(j, 5) = .Cells(i, 20).Value
                                 'BTK Name
                                 Sheets("Sheet1").Cells(j, 6) = .Cells(i, 26).Value
                                 'Product
                                 Sheets("Sheet1").Cells(j, 7) = .Cells(i, 4).Value
                                 'Summary
                                 Sheets("Sheet1").Cells(j, 8) = .Cells(i, 6).Value
                                 'Severity
                                 Sheets("Sheet1").Cells(j, 9) = .Cells(i, 19).Value
                                 'Serial Number
                                 Sheets("Sheet1").Cells(j, 10) = .Cells(i, 8).Value
                                 j = j + 1
                                 Exit For
                            End If
                          End If
                          If .Cells(i, 1) = Dkey And .Cells(i, 2) = "INWORKS" And _
                                .Cells(i, 27) <> "CLS" And .Cells(i, 20) <> "" And Trim(.Cells(i, 11)) = "" Then
                            If .Cells(i, 26) = Third Or .Cells(i, 26) = Fourth Then
                                 Sheets("Sheet2").Cells(k, 1) = Format(Now(), "DD-MMM-YYYY")
                                 'Complaint ID
                                 Sheets("Sheet2").Cells(k, 2) = .Cells(i, 1).Value
                                 'Assigned to Name
                                 Sheets("Sheet2").Cells(k, 3) = .Cells(i, 3).Value
                                 'Aware Date
                                 Sheets("Sheet2").Cells(k, 4) = .Cells(i, 9).Value
                                 '(Initiation)Date Assigned to CI
                                 Sheets("Sheet2").Cells(k, 5) = .Cells(i, 20).Value
                                 'BTK Name
                                 Sheets("Sheet2").Cells(k, 6) = .Cells(i, 26).Value
                                 'Product
                                 Sheets("Sheet2").Cells(k, 7) = .Cells(i, 4).Value
                                 'Summary
                                 Sheets("Sheet2").Cells(k, 8) = .Cells(i, 6).Value
                                 'Severity
                                 Sheets("Sheet2").Cells(k, 9) = .Cells(i, 19).Value
                                 'Serial Number
                                 Sheets("Sheet2").Cells(k, 10) = .Cells(i, 8).Value
                                 k = k + 1
                                 Exit For
                            End If
                        End If
                        If .Cells(i, 1) = Ekey And .Cells(i, 2) = "INWORKS" And _
                           .Cells(i, 27) <> "CLS" And .Cells(i, 20) <> "" And Trim(.Cells(i, 11)) = "" Then
                           If .Cells(i, 26) = Fifth Then
                             Sheets("Sheet3").Cells(m, 1) = Format(Now(), "DD-MMM-YYYY")
                             'Complaint ID
                             Sheets("Sheet3").Cells(m, 2) = .Cells(i, 1).Value
                             'ResolvedBy
                             Sheets("Sheet3").Cells(m, 3) = .Cells(i, 3).Value
                             '(Initiation)Date Assigned to CI
                             Sheets("Sheet3").Cells(m, 4) = .Cells(i, 20).Value
                             'Product
                             Sheets("Sheet3").Cells(m, 5) = .Cells(i, 4).Value
                             'Severity
                             Sheets("Sheet3").Cells(m, 6) = .Cells(i, 19).Value
                             'BTK Name
                             Sheets("Sheet3").Cells(m, 7) = .Cells(i, 26).Value
                             'Problem Statement
                             Sheets("Sheet3").Cells(m, 8) = .Cells(i, 6).Value
                             'Failure Cause
                             Sheets("Sheet3").Cells(m, 9) = .Cells(i, 37).Value
                             'Failure Mode Description
                             Sheets("Sheet3").Cells(m, 10) = .Cells(i, 38).Value
                             'Serial Number
                             Sheets("Sheet3").Cells(m, 11) = .Cells(i, 8).Value
                              m = m + 1
                              Exit For
                           End If
                        End If
                        If .Cells(i, 1) = AHkey And .Cells(i, 2) = "INWORKS" And _
                           .Cells(i, 27) <> "CLS" And .Cells(i, 20) <> "" And Trim(.Cells(i, 11)) = "" Then
                          If .Cells(i, 26) = Sixth Then
                            Sheets("Sheet4").Cells(n, 1) = Format(Now(), "DD-MMM-YYYY")
                            'Complaint ID
                            Sheets("Sheet4").Cells(n, 2) = Sheets("Initial Query Pull").Cells(i, 1).Value
                            'Assigned Name
                            Sheets("Sheet4").Cells(n, 3) = Sheets("Initial Query Pull").Cells(i, 3).Value
                            'Aware Date
                            Sheets("Sheet4").Cells(n, 4) = Sheets("Initial Query Pull").Cells(i, 9).Value
                            'Product
                            Sheets("Sheet4").Cells(n, 5) = Sheets("Initial Query Pull").Cells(i, 4).Value
                            'Summary of Problem
                            Sheets("Sheet4").Cells(n, 6) = Sheets("Initial Query Pull").Cells(i, 6).Value
                            'Severity
                            Sheets("Sheet4").Cells(n, 7) = Sheets("Initial Query Pull").Cells(i, 19).Value
                            'Serial Number
                            Sheets("Sheet4").Cells(n, 8) = Sheets("Initial Query Pull").Cells(i, 8).Value
                            'Initiation Date
                            Sheets("Sheet4").Cells(n, 9) = Sheets("Initial Query Pull").Cells(i, 20).Value
                            'Reportable
                            Sheets("Sheet4").Cells(n, 10) = Sheets("Initial Query Pull").Cells(i, 24).Value
                            'Customer
                            Sheets("Sheet4").Cells(n, 11) = Sheets("Initial Query Pull").Cells(i, 7).Value
                            n = n + 1
                            Exit For
                        End If
                     End If
                     If .Cells(i, 1) = CIAkey And .Cells(i, 2) = "INWORKS" And _
                           .Cells(i, 20) <> "" And Trim(.Cells(i, 11)) = "" Then
                         If .Cells(i, 26) = Seventh Or .Cells(i, 26) = Eighth Or .Cells(i, 26) = Ninth Then
                           Sheets("Sheet5").Cells(o, 1) = Format(Now(), "DD-MMM-YYYY")
                           'Complaint ID
                           Sheets("Sheet5").Cells(o, 2) = .Cells(i, 1).Value
                           'Assigned Name
                           Sheets("Sheet5").Cells(o, 3) = .Cells(i, 3).Value
                           'Date Ready for CI
                           Sheets("Sheet5").Cells(o, 4) = .Cells(i, 20).Value
                           'QA Owner
                           Sheets("Sheet5").Cells(o, 5) = .Cells(i, 25).Value
                           'Product
                           Sheets("Sheet5").Cells(o, 6) = .Cells(i, 4).Value
                           'Age at Last Closure
                           Sheets("Sheet5").Cells(o, 7) = .Cells(i, 12).Value
                           'Summary of Problem
                           Sheets("Sheet5").Cells(o, 8) = .Cells(i, 6).Value
                           'Severity
                           Sheets("Sheet5").Cells(o, 9) = .Cells(i, 19).Value
                           'Serial #
                           Sheets("Sheet5").Cells(o, 10) = .Cells(i, 8).Value
                           'Manufactured Date
                           Sheets("Sheet5").Cells(o, 11) = .Cells(i, 42).Value
                           'Failure Cause
                           Sheets("Sheet5").Cells(o, 12) = .Cells(i, 37).Value
                           'Failure Mode Description
                           Sheets("Sheet5").Cells(o, 13) = .Cells(i, 38).Value
                           'Lot #s 
                           Sheets("Sheet5").Cells(o, 14) = .Cells(i, 30).Value
                           'Customer Name
                           Sheets("Sheet5").Cells(o, 15) = .Cells(i, 7).Value
                           'Rel Description
                           Sheets("Sheet5").Cells(o, 16) = .Cells(i, 35).Value
                            o = o + 1
                            Exit For
                        End If
                     End If
                    Next
                End With
            Next key
        Application.ScreenUpdating = False
    
    
    End Sub

  3. #3
    Board Regular
    Join Date
    Mar 2013
    Posts
    798
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    That's quite the addendum... have not yet looked into it much, but don't think everything should be in a single macro.
    I had come up with this based on the first post.
    Would appreciate if you could test it. You may need to adjust the sheet names as I've used what fit for the file you shared previously.
    Code:
    Sub a_testing()
        
        Dim IQP As Worksheet
        Dim lr As Long, lc As Long
        Dim i As Long, j As Long, wr As Long
        Dim First As String, Second As String, dte As Date
        Dim dataArr As Variant, tmpArr As Variant
        Dim x As Long, dic As Object
        Dim arr As Variant, key As Variant
    
    Set IQP = Sheets("Initial Query Pull")
    
    With IQP
    'load dictionary with Uniques From Column A
        arr = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        Set dic = CreateObject("Scripting.Dictionary")
        For x = 1 To UBound(arr, 1)
          dic(arr(x, 1)) = 1
        Next x
    'last row and column for loading data array
        lr = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        lc = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
        dataArr = .Range(.Cells(1, 1), .Cells(lr, lc)).Value
    End With
    
    'max possible size of tmp array (rows, colums)
        ReDim tmpArr(1 To UBound(dataArr, 1), 1 To 10)  '10 is numb of cols written to sheet
    
    'initial variable values
        First = "Investigate Complaint"
        Second = "Review Product History"
        j = 1
        dte = Format(Now(), "DD-MMM-YYYY")
    
    'loop through data array
        For Each key In dic.keys
            For i = UBound(dataArr, 1) To LBound(dataArr, 1) Step -1  'work from the bottom up
                If dataArr(i, 1) = key And dataArr(i, 2) = "INWORKS" And dataArr(i, 27) <> "CLS" And _
                                   dataArr(i, 20) <> "" And Application.Trim(dataArr(i, 11)) = "" Then
                    If dataArr(i, 26) = First Or dataArr(i, 26) = Second Then
                        'populate tmp array
                        tmpArr(j, 1) = dte                              'current date
                        tmpArr(j, 2) = dataArr(i, 1)                    'Complaint ID
                        tmpArr(j, 3) = dataArr(i, 3)                    'Assigned to Name
                        tmpArr(j, 4) = dataArr(i, 9)                    'Aware Date
                        tmpArr(j, 5) = dataArr(i, 20)                   '(Initiation)Date Assigned to CI
                        tmpArr(j, 6) = dataArr(i, 26)                   'BTK Name
                        tmpArr(j, 7) = dataArr(i, 4)                    'Product
                        tmpArr(j, 8) = dataArr(i, 6)                    'Summary
                        tmpArr(j, 9) = dataArr(i, 19)                   'Severity
                        tmpArr(j, 10) = dataArr(i, 8)                   'Serial Number
                        j = j + 1
                        Exit For
                    End If
                End If
            Next i
        Next key
    
    'write tmp array to sheet
    With Sheets("Workable")
        wr = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'next available row
        .Cells(wr, 1).Resize(j - 1, 10) = tmpArr
    End With
    
    'remove arrays from memory
        Erase arr, dataArr, tmpArr
    
    End Sub

  4. #4
    Board Regular
    Join Date
    Mar 2010
    Location
    New England
    Posts
    414
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    Thanks NoSparks,

    I'll try it and let you know.

    DThib
    Last edited by DThib; Sep 10th, 2019 at 03:27 PM.

  5. #5
    Board Regular
    Join Date
    Mar 2013
    Posts
    798
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    Question...
    after 15 minutes of plugging away, how many rows are typically copied to each of the 5 sheets ?

  6. #6
    Board Regular
    Join Date
    Mar 2013
    Posts
    798
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    also, for the fifth sheet, column 27 is of no concern ?

  7. #7
    Board Regular
    Join Date
    Mar 2010
    Location
    New England
    Posts
    414
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    It would depend on the number of ID matches, It could be as little as none to typically 95. Approvals on last page are generated by all other work on the same ID. (sign-offs)

  8. #8
    Board Regular
    Join Date
    Mar 2010
    Location
    New England
    Posts
    414
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    also, for the fifth sheet, column 27 is of no concern ?


    It could be eliminated if it is hanging things up

  9. #9
    Board Regular
    Join Date
    Mar 2010
    Location
    New England
    Posts
    414
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    In the code you sent yesterday, it keeps hanging up on several worksheets at this point
    Code:
             With Sheets("Decontaminate")
               wr = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'next available row
                .Cells(wr, 1).Resize(j - 1, 10) = tmpArr
             End With
    I keep getting A Run-time Error 1004 from several sheets (Sheet 3 and Sheet 4) why would this happen. I cannot seem to get it corrected.

  10. #10
    Board Regular
    Join Date
    Mar 2013
    Posts
    798
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Another day another wrinkle- Choose last instance of phrase and delete rest of rows

    I regret posting that macro.

    If you're wanting assistance please share a workbook of what you tried and what you tried it with.

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
  •