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

[Dileep Chandran]

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")

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

 

[Corey]

Have you tried removing the line LOOP ?

 

[Dileep Chandran]

Thanks Corey for the timely reply,

But its not working as its showing some compile error, becoz we have Do
and End With.

Any more ideas?

-Dileep

 

[Corey]

What does this do then ?
Sub DeleteBlanks()
'Cut and Paste if Column D is blank

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

Windows("Book1.xls").Activate
Set wks = Worksheets("Sheet1")
myWord = ""
With wks.Range("D")

Set FoundCell = .Cells.Find(what:=myWord,
after:=.Cells(.Cells.Count), lookat:=xlWhole, MatchCase:=False)
If FoundCell Is Nothing Then Exit Sub
On Error Resume Next
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 With
End Sub


Corey....

 

[Dileep Chandran]

Its giving me a syntax error, Corey,,,,,,,

 

[kounoike]

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")
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").SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Copy
worksheets("Sheet2").Paste _
Destination:=worksheets("Sheet2").Cells(1, 1)
Selection.EntireRow.Delete
End Sub

keizi

 

[Dileep Chandran]

Thank you very much Keizi. This is pretty good.

-Dileep