Loop and delete lines till no more lines left to check

I have this code :

Sheet2.Activate
    Sheet2.Range("A:Q").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes
    lrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To lrow
        x = Application.WorksheetFunction.VLookup(Sheet2.Range("B" & i).Value, Sheet3.Range("A:C"), 3, False)
        If x = "x" Then
            Sheet2.Range("B" & i).EntireRow.Delete Shift:=xlUp
        Else
        End If
        Next i

So it loops thru the lines on sheet2.
When it finds a certain value after a lookup in sheet3 it either deletes that line on sheet2 or goes on to the next 'i'.

However now it crashes when all lines are done.
Most likely because I let it run until lrow and because I delete lines lrow is not up to date anymore.

What would be the best way to loop thru all rows on a sheet if you keep deleting lines along the way?

ps: I was thinking of a workaround would be to not do the xlshift up and then at the end do a sort again to lose the blank lines.
But hoping there is a better way