Find result in a worksheet and use to copy information in another

[DThib]

Hello all,

The resource feeding one of my workbooks has changed.

The source now puts an entry everytime it is entered in the database. This results in many lines with almost identical information. I nee to adjust the logic at the start to account for this.
Here is the code:

Sub Workie()


  Dim LastRow, SecondRow As Long
  Dim i As Long
  Dim j As Long
    
    LastRow = Sheets("Initial Query Pull").Cells(Rows.Count, "A").End(xlUp).Row
    SecondRow = Sheets(3).Cells(Rows.Count, "B").End(xlUp).Row
    i = 1 + LastRow
    j = 1 + SecondRow
    For i = 1 To LastRow 'Each i In Sheets("Initial Query Pull")
        If Sheets("Initial Query Pull").Cells(i, 2) = "Work" And Sheets("Initial Query Pull").Cells(i, 27) _
        = "CLS" Is Nothing And Sheets("Initial Query Pull").Cells(i, 20) <> "" And (Sheets("Initial Query Pull").Cells(i, 11) _
        = " " Or Sheets("Initial Query Pull").Cells(i, 11) = "") Then
             Sheets("Workable").Cells(j, 1) = Format(Now(), "DD-MMM-YYYY")
             'Complaint ID
             Sheets(3).Cells(j, 2) = Sheets("Initial Query Pull").Cells(i, 1).Value


             j = j + 1
        End If
    Next i


End Sub

The code needs to account for column 2 for status and then column 3 for name. If these two are found look to column 1 for SampleID and then find the last row (potentially 1,000) that does not state "CLS" in Column 27 and get information.

Any ideas?

 

[NoSparks]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

If you run the Workie macro, you can see it pulls every row matching the arguments.

There are no rows matching the arguments, it pulls nothing.

 

[DThib]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

Sorry, I must have shortened something too much, let me look and I'll reset the dummy workbook.

DThib

 

[DThib]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

https://app.box.com/s/5i7071l7mx2jcp79iy4m1c8tci799xwk

OK, it is fixed.

DThib

 

[NoSparks]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

your current macro copies 172 rows, how many should be copied ?


what's to happen if the macro is run a second time ?


you might want to check the columns for Severity and Serial Number.

 

[DThib]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

Thanks for the reply.

It should copy only 1(one) instance, from the last matching row in "Initial Query Pull" worksheet to "Workable", for each Complaint ID (column B).

DThib

 

[NoSparks]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

It should copy only 1(one) instance, from the last matching row in "Initial Query Pull" worksheet to "Workable", for each Complaint ID (column B).

Will you please stick to the sheet we're working with.
Column A, RECORD_NUMBERs, of which there are 4.

The macro I've come up with copies a total of 2 rows from "Initial Query Pull" to "Workable",
617 for CASE-2019-00000574-1
and 1002 for CASE-2019-00000426-1
is this right or wrong ?

No answer to the question of the macro running a second time ?

 

[DThib]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

Thanks for clarifying for me.
blonde thoughts .

Two would encompass both last checks for column 26 (Z) - "Investigate Complaint" and "Review Product History". I am trying to use either to draw a single row if present. If it is pulling two that is probably why

Macro running twice:
I have a check for stopping the macro from running twice in the same day. It is not in the code I sent.

DThib

 

[NoSparks]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

Try this

Sub Workie_v2()

    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("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

Application.ScreenUpdating = False

    LastRow = Sheets("Initial Query Pull").Cells(Rows.Count, "A").End(xlUp).Row
    SecondRow = Sheets("Workable").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("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("Workable").Cells(j, 1) = Format(Now(), "DD-MMM-YYYY")
                     'Complaint ID
                     Sheets("Workable").Cells(j, 2) = .Cells(i, 1).Value
                     'Assigned to Name
                     Sheets("Workable").Cells(j, 3) = .Cells(i, 3).Value
                     'Aware Date
                     Sheets("Workable").Cells(j, 4) = .Cells(i, 9).Value
                     '(Initiation)Date Assigned to CI
                     Sheets("Workable").Cells(j, 5) = .Cells(i, 20).Value
                     'BTK Name
                     Sheets("Workable").Cells(j, 6) = .Cells(i, 26).Value
                     'Product
                     Sheets("Workable").Cells(j, 7) = .Cells(i, 4).Value
                     'Summary
                     Sheets("Workable").Cells(j, 8) = .Cells(i, 6).Value
                     'Severity
                     Sheets("Workable").Cells(j, 9) = .Cells(i, 19).Value
                     'Serial Number
                     Sheets("Workable").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
        
     'SPR|AssignedTo_Name|DateSPREntered|DateReadyForFI|Product|Summary|Severity|SerialNumber1

End Sub

 

[DThib]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

Hi NoSparks,

It works fantastically! Appreciate your patience and knowledge.
I will work this into the other tabs.

You Rock and Spark!!

DThib

 

[NoSparks]

Re: Extremely complex puzzle to find result in a worksheet and use to copy information in another

Hey that's great, glad to have helped.