Macro to send e-mail for different recipients with different messages

[tomasmello27]

Good afternoon!

I'm trying to create to create a macro that automatically sends e-mails to various addresses, with different messages ('cause each message contains the name of the person).

In an Excel sheet (called "mensagem"), I have the e-mail addresses in column F and the messages in column G. However, all the addresses come from formulas that get them from another sheet (the database of clientes), therefore some clients do not have an e-mail address. I tried to create a macro that reads all the rows and skips those that do not contain an e-mail address. Just to give you an idea, this is part of my table:

Print.jpg

This is the code I wrote, however it is not working. I'm suspecting it's because all my results in row F come from formulas (which can result in the e-mail address or in 0), so the SpecialCells I'm using is wrong. How can I fix that so I can identify the rows different than 0? (I already fixed those with #N/D so they result in 0 as well)

Sub enviaremail()Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range


With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


Set sh = Sheets("Mensagem")


Set OutApp = CreateObject("Outlook.Application")


For Each cell In sh.Columns("F").Cells.SpecialCells(xlCellTypeConstants)


    Set rng = sh.Cells(cell.Row, 1).Range("G1")
    
    If cell.Value Like "#0" And _
        Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        
        With OutMail
            .to = cell.Value
            .Subject = "Antecipação de Parcelas - Teriva Imperatriz"
            .Body = cell.Offset(0, 1).Value
            
                .Send
            End With


            Set OutMail = Nothing
        End If
    Next cell


    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

[Kenneth Hobs]

Maybe:

Sub enviaremail()  Dim OutApp As Object, OutMail As Object
  Dim sh As Worksheet, Cell As Range
  Dim rng As Range
  
  Set sh = Sheets("Mensagem")


  With Application
    .EnableEvents = False
    .ScreenUpdating = False
  End With


  Set OutApp = CreateObject("Outlook.Application")
  
  For Each Cell In sh.Range("F2", sh.Cells(Rows.Count, "F").End(xlUp))
    'Set rng = sh.Cells(cell.Row, 1).Range("G1")  'Same as cell.offset(,1)
    Set rng = Cell.Offset(, 1)
    
    If Cell.Value Like "*@*" And rng <> "" Then
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
        .To = Cell.Value
        .Subject = "Antecipação de Parcelas - Teriva Imperatriz"
        .Body = rng.Value
        .Send
    End With
    Set OutMail = Nothing
  End If
  Next Cell
  
  Set OutApp = Nothing
  With Application
    .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub

[greyangel]

You could just insert code that would ignore all errors and just move on to the next cell.

Sub enviaremail()Dim OutApp As Object 
On error resume next
    Dim OutMail As Object 
    Dim sh As Worksheet 
    Dim cell As Range 
    Dim FileCell As Range 
    Dim rng As Range 
     
     
    With Application 
        .EnableEvents = False 
        .ScreenUpdating = False 
    End With 
     
     
    Set sh = Sheets("Mensagem") 
     
     
    Set OutApp = CreateObject("Outlook.Application") 
     
     
    For Each cell In sh.Columns("F").Cells.SpecialCells(xlCellTypeConstants) 
         
         
        Set rng = sh.Cells(cell.Row, 1).Range("G1") 
         
        If cell.Value Like "#0" And _ 
        Application.WorksheetFunction.CountA(rng) > 0 Then 
            Set OutMail = OutApp.CreateItem(0) 
             
            With OutMail 
                .to = cell.Value 
                .Subject = "Antecipação de Parcelas - Teriva Imperatriz" 
                .Body = cell.Offset(0, 1).Value 
                 
                .Send 
            End With 
             
             
            Set OutMail = Nothing 
        End If 
    Next cell 
     
     
    Set OutApp = Nothing 
    With Application 
        .EnableEvents = True 
        .ScreenUpdating = True 
    End With 
On error goto 0
End Sub

[tomasmello27]

It worked, thank you a lot!

[greyangel]

No problem glad I could help. Please mark this thread as solved.

thank you