Usuário com melhor resposta
Enviar um e-mail em VBA com várias celulas no assunto

Pergunta
-
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
Respostas
-
Deu super certo.
Muito obrigado.
- Marcado como Resposta Jovacir Zanetti quinta-feira, 6 de dezembro de 2018 17:26
Todas as Respostas
-
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
- Editado João Henrique Cavalcanti quinta-feira, 6 de dezembro de 2018 02:17
- Sugerido como Resposta João Henrique Cavalcanti quinta-feira, 6 de dezembro de 2018 03:31
-
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.
-
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
- Marcado como Resposta Jovacir Zanetti quinta-feira, 6 de dezembro de 2018 17:24
- Não Marcado como Resposta Jovacir Zanetti quinta-feira, 6 de dezembro de 2018 17:25
-
Deu super certo.
Muito obrigado.
- Marcado como Resposta Jovacir Zanetti quinta-feira, 6 de dezembro de 2018 17:26