Skip rows with no entry

I want to send emails with VBA based on a table with included email address strEmail.

When there is a row with no email address, I get an error message and only the first row will be sent.

How can I skip rows with no email address until there is a row where strTour_Nr is empty?

Sub sendCustEmails()
        
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(olMailItem)
    
    intRow = 2
    strTour_Nr = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("F" & intRow).Text
    
    While (strTour_Nr <> " ")
        Set objEmail = objOutlook.CreateItem(olMailItem)
    
        'Subject and Body templates are in cells A2 and B2
        strMailSubject = ThisWorkbook.Sheets("Tabelle1").Range("A2").Text
        strMailBody = ThisWorkbook.Sheets("Tabelle1").Range("B2").Text
        
        strTour_Nr = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("F" & intRow).Text
        strUntName = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("C" & intRow).Text
        strEmail = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("P" & intRow).Text
        strVon_Ladedatum = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("K" & intRow).Text
        strVon_Ladezeit = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("M" & intRow).Text
        strBis_Ladezeit = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("N" & intRow).Text
        strPOD_fehlt = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("Q" & intRow).Text
        strIOP_IOD_fehlt = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("R" & intRow).Text
        strPOD_missing = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("S" & intRow).Text
        strIOD_IOP_missing = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("T" & intRow).Text
        
        strMailSubject = Replace(strMailSubject, "<TourNr>", strTour_Nr)
        strMailBody = Replace(strMailBody, "<TourNr>", strTour_Nr)
        strMailBody = Replace(strMailBody, "<Unt_Name>", strUntName)
        strMailBody = Replace(strMailBody, "<Von_Ladedatum>", strVon_Ladedatum)
        strMailBody = Replace(strMailBody, "<Von_Ladezeit>", strVon_Ladezeit)
        strMailBody = Replace(strMailBody, "<Bis_Ladezeit>", strBis_Ladezeit)
        strMailBody = Replace(strMailBody, "<POD_fehlt>", strPOD_fehlt)
        strMailBody = Replace(strMailBody, "<IOP_IOD_fehlt>", strIOP_IOD_fehlt)
        strMailBody = Replace(strMailBody, "<POD_missing>", strPOD_missing)
        strMailBody = Replace(strMailBody, "<IOP_IOD_missing>", strIOD_IOP_missing)       
        
        With objEmail
            .To = CStr(strEmail)
            .Subject = strMailSubject
            .Body = strMailBody
            .Send            
        End With
        
        intRow = intRow + 1
        strTour_Nr = ThisWorkbook.Sheets("2. Ansprechpartner für Touren").Range("F" & intRow).Text
    
    Wend

End Sub

On Error Resume Next seems to work but I don't know how/where to stop it.

Solution

Try setting your Worksheet object and then by using With statement you can make your code shorter and easier to read.

I replaced your While loop condition with a regular For.

See comments within code notes below:

Sub sendCustEmails()
        
    Dim objOutlook As Object
    Dim objEmail As Object
    Dim ws As Worksheet
    Dim LastRow As Long, intRow As Long
    
    Set objOutlook = CreateObject("Outlook.Application")
     
    ' set worksheet object
    Set ws = ThisWorkbook.Sheets("2. Ansprechpartner für Touren")
      
    LastRow = ws.Range("F2").End(xlDown).Row ' get last row with data in worksheet
     
    With ws
        ' loop over rows with data in column F
        For intRow = 2 To LastRow
            If Trim(.Range("F" & intRow).Value) <> "" Then  ' check that column F contains text in it
                        
                Set objEmail = objOutlook.CreateItem(olMailItem)
            
                'Subject and Body templates are in cells A2 and B2
                strMailSubject = ThisWorkbook.Sheets("Tabelle1").Range("A2").Value
                strMailBody = ThisWorkbook.Sheets("Tabelle1").Range("B2").Value
                
        
                strTour_Nr = .Range("F" & intRow).Value
                strUntName = .Range("C" & intRow).Value
                strEmail = .Range("P" & intRow).Value
                strVon_Ladedatum = .Range("K" & intRow).Value
                strVon_Ladezeit = .Range("M" & intRow).Value
                strBis_Ladezeit = .Range("N" & intRow).Value
                strPOD_fehlt = .Range("Q" & intRow).Value
                strIOP_IOD_fehlt = .Range("R" & intRow).Value
                strPOD_missing = .Range("S" & intRow).Value
                strIOD_IOP_missing = .Range("T" & intRow).Value
                
                strMailSubject = Replace(strMailSubject, "<TourNr>", strTour_Nr)
                strMailBody = Replace(strMailBody, "<TourNr>", strTour_Nr)
                strMailBody = Replace(strMailBody, "<Unt_Name>", strUntName)
                strMailBody = Replace(strMailBody, "<Von_Ladedatum>", strVon_Ladedatum)
                strMailBody = Replace(strMailBody, "<Von_Ladezeit>", strVon_Ladezeit)
                strMailBody = Replace(strMailBody, "<Bis_Ladezeit>", strBis_Ladezeit)
                strMailBody = Replace(strMailBody, "<POD_fehlt>", strPOD_fehlt)
                strMailBody = Replace(strMailBody, "<IOP_IOD_fehlt>", strIOP_IOD_fehlt)
                strMailBody = Replace(strMailBody, "<POD_missing>", strPOD_missing)
                strMailBody = Replace(strMailBody, "<IOP_IOD_missing>", strIOD_IOP_missing)
                
                With objEmail
                    .To = CStr(strEmail)
                    .Subject = strMailSubject
                    .Body = strMailBody
                    .Send
                End With
                
                Set objEmail = Nothing ' clear object
        
            End If
            
        Next intRow
    End With

End Sub