looping until certain value is found

Question

I have a following problem (and an urging desire to overcome it:)). I need to make my loop to go through rows until certain value is found. Let me demonstrate what I need in more detail on my code:

For x = 1 To 1000
    If Cells(x, "O").Value = "P" Or Cells(x, "O").Value = "R" Then

        Dim i As Integer
        For i = 1 To 121
            If Worksheets(Cells(x, "P").Value).Cells(Cells(x, "Q").Value + i, "C") = "" Then
                With Worksheets(Cells(x, "P").Value)
                    .Cells(Cells(x, "Q").Value + i, "A").Resize(, 20).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Range("F" & x, "H" & x).Copy
                    .Cells(Cells(x, "Q").Value + i, "E").PasteSpecial xlPasteAll
                    .Cells(Cells(x, "Q").Value + i, "C") = "Pur"
                    Range("AI" & x).Copy
                    .Cells(Cells(x, "Q").Value + i, "O").PasteSpecial xlPasteAll
                End With
            End If
        Next i

    End If  

This code simply goes through rows, and when a specified cell, in this case cell in column "C", is empty it does all the copying and pasting. BUT! It does it as much time as I have denoted it (For i = 1 To 121). What I need is a loop that would loop trough rows until first empty cell in column "D" appears, then perform all the copying and pasting and then STOP. What can I do in order to achieve that?

Please let me know if my question is vague or hard to understand in any way.

As mehow suggested I update my question with a presentation of my try:
Changes are marked with comments

Dim a As Integer 'I introduced new variable
a = 121          'This is it

For x = 1 To 1000
If Cells(x, "O").Value = "P" Or Cells(x, "O").Value = "R" Then

    Dim i As Integer
    For i = 1 To a 'Changes
        If Worksheets(Cells(x, "P").Value).Cells(Cells(x, "Q").Value + i, "C") = "" Then
            With Worksheets(Cells(x, "P").Value)
                .Cells(Cells(x, "Q").Value + i, "A").Resize(, 20).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Range("F" & x, "H" & x).Copy
                .Cells(Cells(x, "Q").Value + i, "E").PasteSpecial xlPasteAll
                .Cells(Cells(x, "Q").Value + i, "C") = "Pur"
                Range("AI" & x).Copy
                .Cells(Cells(x, "Q").Value + i, "O").PasteSpecial xlPasteAll
            End With
        a = i ' This way I wanted to end the loop sooner
        End If
    Next i

End If

Answer 1

I think this is what you're looking for, code commented for clarity:

Sub tgr()

    'Declare variables
    Dim wsData As Worksheet     'Sheet where the data is stored
    Dim wsDest As Worksheet     'Sheet that appropriate data will be copied to
    Dim rngFound As Range       'Range variable used to loop through column O on wsData
    Dim varSheetName As Variant 'Variable used to loop through the sheet names that we will be looking for with rngFound
    Dim strFirst As String      'Used to record the first found cell in order to avoid an infinite loop
    Dim lRow As Long            'Used to determine the row that found data will be pasted to in wsDest

    'Assign wsData to the sheet containing the data
    Set wsData = Sheets("Sheet1")

    'Start the loop by going through each value you are looking for
    'Based on your post, you are looking for "P" and "R"
    For Each varSheetName In Array("P", "R")

        'The values we are looking for are also sheetnames
        'Assign wsDest to the value
        Set wsDest = Sheets(varSheetName)

        'In wsData, look for the value within column "O", must be an exact, case-sensitive match
        Set rngFound = wsData.Columns("O").Find(varSheetName, wsData.Cells(Rows.Count, "O"), xlValues, xlWhole, MatchCase:=True)
        If Not rngFound Is Nothing Then

            'Found a match, record the first match's cell address
            strFirst = rngFound.Address

            'Start a new loop to find every match
            Do

                'Determine the next empty row based on column C within wsDest
                lRow = wsDest.Cells(Rows.Count, "C").End(xlUp).Row + 1

                'Column C at the new row should be set to "Pur"
                wsDest.Cells(lRow, "C").Value = "Pur"

                'Copy columns F:H within wsData and paste to column E within wsDest at the new row
                wsData.Range("F" & rngFound.Row & ":H" & rngFound.Row).Copy wsDest.Cells(lRow, "E")

                'Copy column AI within wsData and paste to column O within wsDest at the new row
                wsData.Cells(rngFound.Row, "AI").Copy wsDest.Cells(lRow, "O")

                'Advance the loop to the next matching cell
                Set rngFound = wsData.Columns("O").Find(varSheetName, rngFound, xlValues, xlWhole, MatchCase:=True)

            'Exit the loop when we are back at the first matching cell
            Loop While rngFound.Address <> strFirst

        End If

    'Advance to the next value (which is a sheet name) that you will be looking for
    Next varSheetName

    'Object variable cleanup
    Set wsData = Nothing
    Set wsDest = Nothing
    Set rngFound = Nothing

End Sub

Answer 2

Artur, the following code will loop copying values from column A to B until it comes across a blank cell, the values "R", "P", or it reaches row 1000. You should be able to modify it for your purposes.

Sub Stack2()
Dim lRowCounter As Long

lRowCounter = 1

Do While lRowCounter < 1000 _
         And Cells(lRowCounter, "A").Value <> "P" _
         And Cells(lRowCounter, "A").Value <> "R" _
         And Cells(lRowCounter, "A").Value <> ""

    Cells(lRowCounter, "B").Value = Cells(lRowCounter, "A").Value


lRowCounter = lRowCounter + 1
Loop

End Sub

Answer 3

Add Exit For at the end of the inner If so that when you execute your copying you can get out of it and get to the next row.