excelvbaoutlook

A VB code is excel that loops through rows in excel to pick information that it uses to send an outlook email runs into error on the 2nd row


Sub email_Advice()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngSubject As Range
    Dim rngRef As Range
    Dim rngBody As Range
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
    ID = CreateObject("WScript.Network").UserName

    Range("V8").Select
    XX = ActiveCell.Row
    
Next_Ref:
    If Range("V" & XX).Value = "" Then
        If ActiveCell.Offset(0, -1).Value = "" Then
        
        Set objOutlook = Nothing
        Set objMail = Nothing
        Set rngTo = Nothing
        Set rngSubject = Nothing
        Set rngBody = Nothing
        
        Exit Sub
        Else
        MsgBox ("Click to generate for next vendor")
        With ActiveSheet
            Set rngTo = .Range("M" & XX)
            Set rngSubject = .Range("O" & XX)
            Set rngBody = .Range("P" & XX)
            Set rngRef = .Range("T" & XX)
        End With
        
        With objMail
         .To = rngTo.Value
         .Subject = rngSubject.Value
         .Body = rngBody.Value
         .Attachments.Add "C:\Users\" & ID & "\Desktop\WHT \" & rngRef & ".pdf"
            .Send
        End With
        
        ActiveCell.Value = "YES"
        ActiveCell.Offset(1, 0).Select
        XX = XX + 1
        GoTo Next_Ref
        End If
    Else
    
    Exit Sub
    End If
    
End Sub

I executed the code above and was expecting it to loop through each rows, picking the necessary information to send an email, until a blank cell is reached. However, the code always encounters below error on the 2nd row: "Run time error" with the description: "The items has been moved or deleted"


Solution

  • Untested

    Option Explicit
    
    Sub email_Advice()
        Dim objOutlook As Object, objMail As Object
        Dim ID As String, FOLDER as String
        Dim lastrow As Long, r As Long, n As Long
        
        ID = CreateObject("WScript.Network").UserName
        FOLDER = "C:\Users\" & ID & "\Desktop\WHT \"
        Set objOutlook = CreateObject("Outlook.Application")
    
        With ActiveSheet
            lastrow = .Cells(.Rows.Count, "U").End(xlUp).Row
            For r = 8 To lastrow
                If .Cells(r, "V") = "" Then
                    If vbYes = MsgBox("Generate for vendor " & .Cells(r, "M"), vbYesNo) Then
                        Set objMail = objOutlook.CreateItem(0)
                        With objMail
                            .To = .Cells(r, "M")
                            .Subject = .Cells(r, "O")
                            .Body = .Cells(r, "P")
                            .Attachments.Add FOLDER & .Cells(r, "T") & ".pdf"
                            .Send
                        End With
                        .Cells(r, "V") = "YES"
                        n = n + 1
                    End If
                End If
            Next
        End With
        
        Set objOutlook = Nothing
        Set objMail = Nothing
        
        MsgBox n & " emails sent", vbInformation
    
    End Sub