Have you tried removing the line LOOP ?

Following your code, i just changed your exit Do condition.

Sub DeleteBlanks()
'Cut and Paste if Column D is blank
   Dim myWord As String
   Dim FoundCell As Range
   Dim wks As Worksheet
   Dim lastcell As Range

   Windows("Test.xls").Activate
   Set wks = worksheets("Sheet1")
   Set lastcell = wks.Cells.Find(What:="*", _
               After:=Range("A1"), _
               SearchOrder:=xlByRows, _
               SearchDirection:=xlPrevious).Offset(1, 0)
   myWord = ""
   With wks.Range("D:D")
       Do
           Set FoundCell = .Cells.Find(What:=myWord, _
                           After:=.Cells(.Cells.Count), _
                           lookat:=xlWhole, MatchCase:=False)
           If FoundCell.Row >= lastcell.Row _
                   Or FoundCell Is Nothing Then
               Exit Do
           Else
               FoundCell.EntireRow.Select
               Selection.Cut
               sheets("Sheet2").Select
               Cells(Rows.Count, 1).End(xlUp)(2).Select
               ActiveSheet.Paste
               sheets("Sheet1").Select
               Selection.EntireRow.Delete
           End If
       Loop
   End With
End Sub

and in my thought below is a alternative to do almost same above.

Sub DeleteBlankstest()
Windows("Test.xls").Activate
Range("D:D").SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Copy
worksheets("Sheet2").Paste _
   Destination:=worksheets("Sheet2").Cells(1, 1)
Selection.EntireRow.Delete
End Sub

keizi