looping through range of cells & sending multiple emails with outlook

Hello,

What I'm trying to do is loop through a range of cells and send out an email to certain recipients if information has changed. I am starting with row 6 and checking each column in row 6 to see if any changes have been made. All the changes in row 6 are then added to the body of the email message. Once the email is sent, the loop moves to the next row and starts over with a new email. The problem I'm having is that the email will only send for changes made in the first row(row 6). Once the loop moves to row 7, i get an error stating: "Outlook does not recognize one or more names." When I click "debug", the .Send code is highlighted.

Here is the code:

Sub SendEmail()

Dim Msg As String
Dim OutlookApp As Object
Dim Outmail As Object
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
 
Set OutlookApp = CreateObject("Outlook.Application")
OutlookApp.Session.Logon

z = 0
For y = 6 To 500
    Msg = ""
    For x = 2 To 100
        If ThisWorkbook.Worksheets("Open jobs").Cells(y, x).Interior.ColorIndex = 4 Then
    
            If z = 0 Then
                Msg = "Job number " & ThisWorkbook.Worksheets("Open jobs").Range("B" & y).Value & " has had changes made to it! " & Chr(13)
                z = 1
            Else
            End If
            changed_value = ThisWorkbook.Worksheets("Open jobs").Cells(y, x).Value
            changed_catergory = ThisWorkbook.Worksheets("Open jobs").Cells(5, x).Text
            previous_value = ThisWorkbook.Worksheets("Backup Sheet").Cells(y, x).Value
            
            Msg = Msg & changed_catergory & " was changed from " & previous_value & " to " & changed_value & Chr(13)
        
        Else
        End If
    Next x
    
    If Msg = "" Then
    Else
        Subj = "Job Change"
        Recipient = ThisWorkbook.Worksheets("Open jobs").Range("F" & y).Text
        EmailAddr = Recipient & "@whoever.com"
        
        Set Outmail = OutlookApp.CreateItem(0)
        
        With Outmail
            .to = EmailAddr
            .Subject = Subj
            .Body = Msg
            .Send
        End With
        
        Set Outmail = Nothing
        z = 0
    End If
    
Next y

Set OutlookApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Also, I used the www.rondebruin.nl site to get the code for sending emails. Any help would be greatly appreciated. Thanks!

Scott

Hello splosczynski,

The method mrice mentioned will work only if all the addresses listed on your worksheet are in your personal address book. Check that your email addresses are correct and there are no typographical errors.

Sincerely,
Leith Ross