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:
Help, please...
DThib
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 SubHelp, please...
DThib
Last edited:
