Macro - Issue with cut and paste if a column is blank
 

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

"Dileep Chandran" wrote in message
ups.com...
Hi Everybody,

I have a macro to cut and paste the entire row if the cell D is blank.
But I am facing an issue as its not stopping untill I press Esc button.
I need it to stop once it finish checking the last row which contain
data.

The macro is as follows:

Sub DeleteBlanks()
'Cut and Paste if Column D is blank

Dim myWord As String
Dim FoundCell As Range
Dim wks As Worksheet


Windows("Test.xls").Activate
Set wks = Worksheets("Sheet1")


myWord = ""


With wks.Range("D:D")

Do
Set FoundCell = .Cells.Find(what:=myWord, _
after:=.Cells(.Cells.Count), _
lookat:=xlWhole, MatchCase:=False)
If 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

Any help is appreciated

Thanks

-Dileep

Macro - Issue with cut and paste if a column is blank
 

Thank you very much Keizi. This is pretty good.

-Dileep