Enviar um e-mail em VBA com várias celulas no assunto

Question

Boa noite.

Estou precisando mandar um e-mail automático para vários clientes onde solicito documentos onde cada um terá sua solicitação específica.

EX: Cliente x

Documentos:

Documento 1

Documento 2, etc.

Estou usando o código abaixo, porém ele só permite enviar o conteúdo de uma célula:

Sub MandaEmail()
    
    Dim EnviarPara As String
    Dim Mensagem As String
    For i = 1 To 10
        EnviarPara = ThisWorkbook.Sheets(1).Cells(i, 1)
        If EnviarPara <> "" Then
            Mensagem = ThisWorkbook.Sheets(1).Cells(i, 3) (aqui eu preciso que ele retorne no e-mail várias linhas dessa coluna)
            Envia_Emails EnviarPara, Mensagem
        End If
    Next i
End Sub

Sub Envia_Emails(EnviarPara As String, Mensagem As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = EnviarPara
        .CC = ""
        .BCC = ""
        .Subject = "DOCUMENTOS CONTÁBEIS DA EMPRESA " + Range("D1").Text + " DO MÊS " + Range("E1").Text
        .Body = Mensagem
        .Display ' para envia o email diretamente defina o código  .Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Se alguém puder ajudar, agradeço.

Jovacir

Answer 1

opa meu amigo tudo bem ? faz assim :

Por favor marca como respondido e vota pelo meu post , isso me ajuda, obrigado.

Sub MandaEmail()
    
    Dim EnviarPara As String
    Dim Mensagem As String
    For i = 1 To 10
        EnviarPara = ThisWorkbook.Sheets(1).Cells(i, 1)
        If EnviarPara <> "" Then
           

Mensagem=""

for x= 1 to 100 '' aqui você escreve até que que célula quer que o o centeudo seja adiciona a mensagem

Mensagem = Mensagem & " " & ThisWorkbook.Sheets(1).Cells(x, 3) 

next x

            Envia_Emails EnviarPara, Mensagem
        End If
    Next i
End Sub

Sub Envia_Emails(EnviarPara As String, Mensagem As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = EnviarPara
        .CC = ""
        .BCC = ""
        .Subject = "DOCUMENTOS CONTÁBEIS DA EMPRESA " + Range("D1").Text + " DO MÊS " + Range("E1").Text
        .Body = Mensagem
        .Display ' para envia o email diretamente defina o código  .Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Answer 2

Bom dia João. 

Deu certo. Só há uma questão: fica tudo na mesma linha. Há como separar? Tipo, o que está em cada célula ficar em cada linha no e-mail?

Ficou assim:

 Prezado (a),  Favor enviar os documentos abaixo referentes ao mês de 12/2018 da Empresa X para que possamos contabilizar:  Arquivo em Excel das Contas Pagas  no mês do Financeiro Relatórios/Extratos das vendas realizadas com cartões (Débito e Crédito) Extrato conta BANCO DO BRASIL - C/C xxxx - PDF E OFX Extrato conta  BANCO C.E.F - C/C xxxxx - PDF E OFX Departamento contábil 

Queria assim:

 Prezado (a), 

Favor enviar os documentos abaixo referentes ao mês de 12/2018 da Empresa X para que possamos contabilizar: 

Arquivo em Excel das Contas Pagas  no mês do Financeiro

Relatórios/Extratos das vendas realizadas com cartões (Débito e Crédito)

Extrato conta BANCO DO BRASIL - C/C xxxx - PDF E OFX

Extrato conta  BANCO C.E.F - C/C xxxxx - PDF E OFX

Departamento contábil 

Agradeço.

Answer 3

substitua essa parte do codigo:

por favor se isso te respondeu marque como resposta e vote pelo meu post , isso me ajuda e ajuda os outros usuários. obrigado amigo !

Mensagem=""

for x= 1 to 100 '' aqui você escreve até que que célula quer que o o centeudo seja adiciona a mensagem

Mensagem = Mensagem & " " & ThisWorkbook.Sheets(1).Cells(x, 3) & chr(10) ' esse comendo faz a quebra de linha

next x

Answer 4

Deu super certo.

Muito obrigado.