Looping with find and replace

Hi,

Can someone tell me how loop this code downwards over the A and B columns? Right now, it works on sheet 1 only to replace all instances of the text in Sheet 3, A1, with the text in Sheet 3, B1, but I want it to do the same thing again, replacing A2 with B2, etc, and then stop when it hits a blank cell in the A column.

Sub ExecuteSearches()
'
' ExecuteSearches Macro
'
    Sheets("Sheet1").Select
    Cells.Replace What:=Sheets("Sheet3").Range("A1"), Replacement:=Sheets("Sheet3").Range("B1"), LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


End Sub

Thanks for reading