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

DThib

Active Member
Joined
Mar 19, 2010
Messages
464
Office Version
  1. 365
Platform
  1. Windows
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:

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
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 [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=s]#s[/URL] 
                       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
 
Upvote 0
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
 
Upvote 0
Thanks NoSparks,

I'll try it and let you know.

DThib
 
Last edited:
Upvote 0
Question...
after 15 minutes of plugging away, how many rows are typically copied to each of the 5 sheets ?
 
Upvote 0
also, for the fifth sheet, column 27 is of no concern ?
 
Upvote 0
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)
 
Upvote 0
also, for the fifth sheet, column 27 is of no concern ?


It could be eliminated if it is hanging things up
 
Upvote 0
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
[U][B][COLOR=#b22222]            .Cells(wr, 1).Resize(j - 1, 10) = tmpArr[/COLOR][/B][/U]
         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.
 
Upvote 0
I regret posting that macro.

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

Forum statistics

Threads
1,213,534
Messages
6,114,184
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top