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

[DThib]

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:

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

 

[DThib]

Thanks,

I think I figured it out.

DThib

 

[NoSparks]

Out of curiosity, any time improvement ?

 

[DThib]

Yes.
It now takes 1 minute and 55 seconds for the large download. About 1 minute 30 seconds for the individual tabs.
Thanks for your help!

You are Sparky!!!

 

[NoSparks]

Hmmm... that's still about 8 minutes with things moved from the IQP sheet into memory to be worked with.
I'd have expected a much greater improvement than that.
Have a suspicion I don't handle the in memory arrays properly or efficiently.
Anyway if you're happy, I'm happy.
Thanks for letting me know.

 

[DThib]

It is still Waaaaaaay better than before 8 minutes per Tab and 18 minutes for a complete download.

Thanks for the tweak on the code.

DThib