Loop through list and find all additional criteria, then add below.

[RockandGrohl]

Hello,

Have a situation developing here.

There is one sheet "CT" which has a list of products and the dates next to them.

The list is incomplete and I need to fill criteria from another sheet, "PP"

This is what I have so far.

Dim Lastrow As Long, Row As Long



Set ct = Worksheets("Campaign TourRefs")


Set pp = Workbooks.Open("H:\Sales\Price Panels\Price Panels 2019.xlsm", ReadOnly:=True)
Range("A3").Activate
ct.Activate




Range("A3").Activate


Do Until Cells(ActiveCell.Row, "A").Value = ""
    MLTOUR = Cells(ActiveCell.Row, "A").Value
    MLDATE = Cells(ActiveCell.Row, "B").Value
    Row = Cells(ActiveCell.Row)
    pp.Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "A").Value <> MLTOUR Then
        ActiveCell.Offset(1, 0).Activate
        Else
        PPNAME = Cells(ActiveCell.Row, "C").Value
            Do Until Cells(ActiveCell.Row, "A").Value = ""
            If Cells(ActiveCell.Row, "C").Value = PPNAME And Cells(ActiveCell.Row, "M").Value = MLDATE And Cells(ActiveCell.Row, "K").Value = "Megacoach" Then
            PPTOUR = Cells(ActiveCell.Row, "A").Value
            ct.Activate
            Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
            Range("A" & Lastrow + 1).Activate
            Cells(ActiveCell.Row, "A").Value = PPTOUR
            Cells(ActiveCell.Row, "B").Value = MLDATE
            pp.Activate
            Else
            ActiveCell.Offset(1, 0).Activate
            
            
            End If
            ActiveCell.Offset(1, 0).Activate
            Loop
        
        End If
        Loop


ct.Activate
Range("A" & Row + 1).Activate
ActiveCell.Offset(1, 0).Activate
Loop

What I need to do:

In CT, the table is laid out with a list of products in column A and a list of dates in col. B

I need to select the first product in cell A3, hold that and the date as a variable (MLTOUR and MLDATE)

Then switch to PP, and start a loop going from top to bottom until I run out of rows of data.

When I find a value in column A that matches the MLTOUR, it needs to hold the NAME of the product as PPNAME. Then, I need to loop down from that point within PP until I find a row that fits the following 3 critera:

• MLTOUR is matched in Column C
• MLDATE is matched in Column M
• Column K value is "Megacoach"

From here, I need to set the value in that row, column A as "PPTOUR"

Once that is set, switch back to CT, jump to the bottom and then place "PPTOUR" and "MLDATE" in columns A and B respectively, then, return back to the same row I was on before, jump down one, then repeat the whole process.

WHEW!

So essentially I'm looking up in PP a series of criteria then appending the data in CT. The critical part is that it needs to stop once I've exhausted the list - this is a problem if I'm appending data constantly because if my original list is 20 long and I append another 50, it will want to look through 70 items, even though it should look at 20.

I've never used it before so I need help, but would "For x" help? Where I tell VBA there's 20 lines so when you get to line 21, stop?

Thank you.

 

[RockandGrohl]

I solved this all by myself.

I was running into issues because, like a sperg, I seem to ignore my own best advice of "If you open a loop, close it immediately and then go back and fill in what you want the loop to do"

As a result I had a tangled mess that I couldn't mentally untangle.

I also set up two more Long's - one was Workload - this calculated how many rows I had initially and I changed my Do Until to simply stop when it reaches the end of the workload.

The other piece of logic was to record the "row" I am checking PP against, and then once I have appended the list, to return to that row + 1 to get to the next item.

Here's the new working code:

Range("A3").Activate

workload = Cells(Rows.Count, "A").End(xlUp).Row - 2




Do Until ActiveCell.Row = workload + 3
    MLTOUR = Cells(ActiveCell.Row, "A").Value
    MLDATE = Cells(ActiveCell.Row, "B").Value
    Row = ActiveCell.Row
    pp.Activate
    Range("A3").Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "A").Value <> MLTOUR Then
        ActiveCell.Offset(1, 0).Activate
        Else
        PPNAME = Cells(ActiveCell.Row, "C").Value
            Do Until Cells(ActiveCell.Row, "A").Value = ""
            If Cells(ActiveCell.Row, "C").Value = PPNAME And Cells(ActiveCell.Row, "M").Value = MLDATE And Cells(ActiveCell.Row, "K").Value = "Megacoach" And Cells(ActiveCell.Row, "B").Value <> "Cancelled" Then
            PPTOUR = Cells(ActiveCell.Row, "A").Value
            ct.Activate
            Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
            Range("A" & Lastrow + 1).Activate
            Cells(ActiveCell.Row, "A").Value = PPTOUR
            Cells(ActiveCell.Row, "B").Value = MLDATE
            pp.Activate
            Else
            
            
            End If
            ActiveCell.Offset(1, 0).Activate
            Loop
        
        End If
        Loop


ct.Activate
Range("A" & Row + 1).Activate
Loop
    


    Columns("A:B").Select
    ActiveSheet.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), _
        Header:=xlNo


pp.Close False




Application.ScreenUpdating = True