Leaves blank rows after row with specific word moved to sheet 2

[hsolanki]

Hi everybody

i have found this code from here and it works perfect however when it is cut it from Sheet 1 to Sheet 2 with specific word "Completed" it cut all the rows that contains "Completed" on column "AG" however it then leave the blanks rows on sheet1 is there any way that when it is moved to sheet 2 from sheet1 it will continue to look for next row with the specific word and will also continue to delete each blank rows.

Option Explicit
Sub Test()

Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long

Set sht1 = ThisWorkbook.Worksheets("Full")
Set sht2 = ThisWorkbook.Worksheets("Completed")

For i = 2 To sht1.Cells(sht1.Rows.Count, "AG").End(xlUp).Row
    If sht1.Range("AG" & i).Value = "Completed" Then
 sht1.Range("A" & i).EntireRow.Cut Destination:=sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "AG").End(xlUp).Row + 1)
     
    End If
Next i

End Sub

 

[Fluff]

How about

Sub Test()

Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Dim Rng As Range

Set sht1 = ThisWorkbook.Worksheets("Full")
Set sht2 = ThisWorkbook.Worksheets("Completed")

For i = 2 To sht1.Cells(sht1.Rows.Count, "AG").End(xlUp).Row
   If sht1.Range("AG" & i).Value = "Completed" Then
      sht1.Range("A" & i).EntireRow.Copy Destination:=sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "AG").End(xlUp).Row + 1)
      If Rng Is Nothing Then Set Rng = sht1.Rows(i) Else Set Rng = Union(Rng, sht1.Rows(i))
    End If
Next i
If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

 

[hsolanki]

Hi Mr Fluff Thank you so much it worked as i wanted to work

 

[Fluff]

You're welcome & thanks for the feedback.