Este fórum está sendo desativado

[wallacerodrigo57]

Boa Noite Pessoal,

Estou tentando criar um código para envio de email pelo excel. Porém, não estou conseguindo resolver as inconsistências do código, poderiam ajudar por favor?

Erros que detectei, ele informa que foi enviado o email mesmo sem enviar nenhum email.
Next sem For... também não sei como resolver esse problema
E em alguns testes o Loop do script falha não sei porque.

Segue abaixo o código:

Código: Selecionar todos

Public Sub EnviarEmail()
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
'Referência à biblioteca do Outlook
Dim outapp As Outlook.Application
Dim outmail As Outlook.MailItem

Dim i As Integer, row As Integer
Dim ContactRow, LastRow, SentCounter As Long

Set wb = ThisWorkbook
Set ws = wb.Sheets("Mailing")

i = 16
row = ws.Range("B" & Rows.Count).End(xlUp).row

'Convertendo "," para ";"
Range("C16:E16").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace What:=",", Replacement:=";", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

'Inicializando o Aplicativo do MS-Outlook
Set outapp = New Outlook.Application

'Do While i <= row
      
    If ws.Range("L" & i).Value <> Empty Then GoTo NextRow
    
'Novo Email
Set outmail = outapp.CreateItem(olMailItem)
With outmail
    .Display
    .To = ws.Range("C" & i).Value
    .CC = ws.Range("E" & i).Value
    .BCC = ws.Range("E" & i).Value
    .Subject = ws.Range("F" & i).Value
    .Body = Range("C4").Value
              If ws.Range("G" & i).Value <> "" Then
              .Attachments.Add ws.Range("G" & i).Value
              End If
              If ws.Range("H" & i).Value <> "" Then
              .Attachments.Add ws.Range("H" & i).Value
              End If
              If ws.Range("I" & i).Value <> "" Then
              .Attachments.Add ws.Range("I" & i).Value
              End If
              If ws.Range("J" & i).Value <> "" Then
              .Attachments.Add ws.Range("J" & i).Value
              End If
              If ws.Range("K" & i).Value <> "" Then
              .Attachments.Add ws.Range("K" & i).Value
              End If
    .Importance = olImportanceHigh
    '.Send
End With
    
     SentCounter = SentCounter + 1
        ws.Range("L" & i).Value = Now 'Set Send Date & Time
        
NextRow:
    Next i
    
    'Liberar Memória
    Set outmail = Nothing
    Set outapp = Nothing
    Set ws = Nothing
    Set wb = Nothing

MsgBox SentCounter & " Emails have been sent"
End Sub

Desde já muito obrigado a todos.

[mprudencio]

Teste ai!

Troque

Next i

por

loop