Move and delete the active row in VBA

[Tiny_t]

Good Day,

I am working on a automated handover code to send an mail and all is working perfectly.

I would like to move the active cell to the next sheet after the last row there and then delete the blank row as well.

I have tried different examples from the web but with no luck

Sub Handover()
    
    Dim OutApp As Object
    Dim OutMail As Object
  Dim r As Integer
   
  
    For r = 2 To 200 'data in rows 2-4
    If Not IsEmpty(Sheets("WIP").Cells(r, 19)) Then
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Dim Msg As String
    Dim signature As String


    
    
    Msg = ""
  
 
 
 SigString = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Auto.htm"


    If Dir(SigString) <> "" Then
        signature = GetBoiler(SigString)
    Else
        signature = ""
    End If


    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = """
        .HTMLbody = Msg & vbNewLine & signature
        
        
        .display '.Send
        
    End With
    
    On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
   
   
 
               
    Else
        End If
        Next r


End Sub

 

[Tiny_t]

Good Day,

I am working on a automated handover code to send an mail and all is working perfectly.

I would like to move the active cell to the next sheet after the last row there and then delete the blank row as well.

I have tried different examples from the web but with no luck

Sub Handover()
    
    Dim OutApp As Object
    Dim OutMail As Object
  Dim r As Integer
   
  
    For r = 2 To 200 'data in rows 2-4
    If Not IsEmpty(Sheets("WIP").Cells(r, 19)) Then
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Dim Msg As String
    Dim signature As String


    
    
    Msg = ""
  
 
 
 SigString = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Auto.htm"


    If Dir(SigString) <> "" Then
        signature = GetBoiler(SigString)
    Else
        signature = ""
    End If


    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = """
        .HTMLbody = Msg & vbNewLine & signature
        
        
        .display '.Send
        
       
        

    End With
    
    On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
   
   
 
               
    Else
        End If
        Next r


End Sub

had a blonde moment added code right after .Display

Sheets("WIP").Cells(r, 1).EntireRow.Cut Destination:= _
Sheets("Hand overs").Range("A" & Rows.Count).End(xlUp).Offset(1)
Sheets("WIP").Cells(r, 1).EntireRow.Delete

this is now working perfectly

 

[Tiny_t]

Works fine But only does one at a time and does not continue through the original list

so if i have 2 "handovers" i need to run the code twice

 

[Tiny_t]

Finally solved it

...
  .display '.Send
        
    End With
    
    Sheets("WIP").Cells(R, 1).EntireRow.Cut Destination:= _
    Sheets("Hand overs").Range("A" & Rows.Count).End(xlUp).Offset(1)
        
    
    On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
   
  
        
         
    Else
        End If
        Next R
        
   Dim LastRow As Long
   Dim Counter As Long
   
   Application.ScreenUpdating = False
   LastRow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1
   For R = LastRow To 1 Step -1
   If Application.WorksheetFunction.CountA(Rows(R)) = 0 Then
   Rows(R).Delete
   Counter = Counter + 1
   End If
   Next R
   Application.ScreenUpdating = True



End Sub