跳过没有条目的行

Question

我想根据包含电子邮件地址的表格使用 VBA 发送电子邮件

strEmail

。

当有一行没有电子邮件地址时，我会收到一条错误消息，并且只会发送第一行。

如何跳过没有电子邮件地址的行，直到出现

strTour_Nr

为空的行？

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

似乎有效，但我不知道如何/在哪里停止它。

Answer 1

尝试设置您的

Worksheet

对象，然后使用

With

语句，您可以使代码更短且更易于阅读。

我用常规的

While

替换了你的

For

循环条件。

请参阅下面代码注释中的注释：

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