Ir ao conteúdo
  • Cadastre-se

VBA Enviar varios emails Excel


Ir à solução Resolvido por Wendell Menezes,

Posts recomendados

Pessoal, boa tarde.

 

Toda semana envio um relatório para +- 170 fornecedores diferentes com os pedidos gerados no mês/semana. Isso consome MUITO tempo, chegando a demorar o dia todo para fazer manualmente.

Preciso da ajuda de vocÊs para automatizar esse processo.

 

Hoje, consegui montar um código VBA que separa todos os fornecedores em abas diferentes, cada um em uma aba.

Agora preciso de um código para enviar cada aba criada para o fornecedor correto. Exemplo: Foi criado uma aba para o fornecedor "Ferramentas Gerais" e uma para o fornecedor "Teadit", preciso que  aba da FG seja enviada para o email da FG e a aba da Teadit para o respectivo email.

 

Tenho uma aba com o nome e email de cada fornecedor.

 

Se possível queria que o código cruzasse o nome da aba com o do fornecedor, anexe a aba no outlook e enviasse para o email correto. Lembrando que a qualquer momento pode surgir mais fornecedores, por isso queria que cruzasse a aba com o fornecedor (aba "banco_dados').

 

Já procurei muito por essa resposta, mas a maioria o vba salva a aba em algum lugar e voce tem que colocar o endereço no código... Mas isso acaba ficando inviavel, já que são mais de 170!!!!!

 

Em anexo segue arquivo de teste e para maior compreensão (a macro para separar os fornecedores em abas esta la).

 

Desde já agradeço a todos! Vão me salvar umas horas de trabalho!!!!

Macro Abas Emails.rar

Link para o comentário
Compartilhar em outros sites

Olá,

 

1) Pressione ALT+F11 para abrir o editor VBA, depois pressione ALT+F para abrir o menu Ferramentas e clique sobre Referências. Agora certifique-se de procurar e ativar todas as referências da imagem anexa.

2) Altere o valor da variável Folder com o caminho de uma pasta que exista no seu PC.

 

Agora rode o código abaixo, que irá criar um arquivo por fornecedor e gerar um e-mail com o excel anexo.

Sub Send_Emails()Dim Folder As String, HTMLBody As String, Recipient As StringDim db As DAO.DatabaseDim rs As DAO.Recordset, rs2 As DAO.RecordsetDim c As LongDim OA As Object, OM As ObjectApplication.DisplayAlerts = FalseFolder = "C:\Users\Wendell\Desktop\A\"     HTMLBody = "Prezado Fornecedor,<br>" & _     "<br>" & _"Você está recebendo a lista de pedidos de compras que foram gerados e enviados a sua empresa pela Braskem na semana anterior e que até esta data se encontra com o status de ""PEDIDO EM ABERTO"".<br>" & _"A lista anexa possui pedidos de compras gerados de LOJAS IN HOUSE (LIH) e também pedidos de compras de contratos de LISTA DE PREÇOS (LP), como é de conhecimento os pedidos de compras de LIH devem ser atendido em até 24 horas e para os pedidos de compras de LP temos o campo de DATA DE REMESSA, sendo esta a data que deve ser cumprida para a entrega.<br>" & _"Solicitamos que estes pedidos sejam analisados e caso seja necessário justifique o motivo do atraso na entrega ou se o material já foi entregue informar o N° da Nota Fiscal e a Data Emissão da nota, na mesma planilha anexa há três colunas que devem ser preenchidas com essas informações.<br>" & _"Esta planilha possui dados semanais e serão acumulativos, portanto pedidos em abertos das semanas anteriores estarão presentes até o fechamento do mês corrente, importante reforçar que o retorno desta planilha deve ser efetuado para este mesmo endereço em até 4 dias após o seu recebimento.<br>" & _"Qualquer dúvida, ficamos à disposição." & _"<br>" & _"<br>Sds."Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")Set rs = db.OpenRecordset("SELECT DISTINCT [Forn agru] FROM [Plan1$]")Set OA = CreateObject("Outlook.Application")While Not rs.EOF    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Forn agru]='" & rs(0) & "'")    Workbooks.Add        For c = 0 To rs2.Fields.Count - 1            Cells(1, c + 1) = rs2.Fields(c).Name        Next    Range("A2").CopyFromRecordset rs2    Range("A:AZ").EntireColumn.AutoFit    ActiveWorkbook.Close True, Folder & rs(0)    Set OM = OA.CreateItem(0)        With OM            Recipient = db.OpenRecordset("SELECT [email] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            .To = Recipient            .CC = "[email protected]<script data-cfhash='f9e31' type="text/javascript">/*  */</script>"            .Subject = "Follow-Up - Lista de Pedidos Emitidos Braskem"            .HTMLBody = HTMLBody & "<br>"            .Attachments.Add Folder & rs(0) & ".xlsx"            .Display        End With    rs.MoveNextWendEnd Sub

post-595425-0-56749300-1442526497.png

  • Curtir 1
Link para o comentário
Compartilhar em outros sites

            .CC = "[email protected]<script data-cfhash='f9e31' type="text/javascript">/*  */</script>"

 Agora deu erro aqui!

 

Erro de sintaxe.

 

Pior que não sei nem como tentar arrumar isso, já esta um nivel muito acima do meu!!!!

 

Mas desde já te agradeço pelo ajuda Wendell

Link para o comentário
Compartilhar em outros sites

Ahh, acho que o forum não permite postar e-mails.

 

Essa linha era pra ser assim:

.CC = "barbara.vigilato braskem.com"

Com um @ ao invés de espaço

Wendell, bom dia.

 

Testei o código em uma planilha maior.

O 1º fornecedor vai certinho, porém a partir do 2º da erro.

 

Aparece a seguinte msg:

Erro__1_.JPG?sbsr=bc48857a2bc7cd68c3d24f

 

Pode me ajudar?

post-770179-0-91029800-1443187254_thumb.

Link para o comentário
Compartilhar em outros sites

  • 2 semanas depois...

Marcus,

 

Apenas com a mensagem de erro não. Envie a sua planilha para eu ver exatamente o que está causando o problema.

 

Abs

Wendell, segue o arquivo.

 

https://drive.google.com/file/d/0Bz6COcSmLXMfU240SFdmSGs3LTA/view?usp=sharing

 

Esse código salva as abas criadas em uma pasta, se eu precisar rodar novamente eu tenho que ir la e apagar o arquivo anterior. Tem como fazer ele deletar o arquivo sozinho após o uso?

 

Obrigado!

Link para o comentário
Compartilhar em outros sites

Olá,

 

A planilha não possui dados de teste e o código VB não possui a linha onde seu screenshot anteior acusava erro.

 

Eu tinha mandado a errada, desculpa. Editei, mas acho que você ja tinha pegado.

 

A correta é: https://drive.google.com/file/d/0Bz6COcSmLXMfU240SFdmSGs3LTA/view?usp=sharing

Link para o comentário
Compartilhar em outros sites

Que estranho, aqui funcionou normal para os 10 fornecedores. Nesse exemplo você está tendo o mesmo problema?

Quando eu executo a macro o primeiro fornecedor funciona normalmente, porém antes de rodar o segundo aparece aquele erro que enviei. "O modo CopyFromRecordSet do objeto Range falhou".

Que estranho, aqui funcionou normal para os 10 fornecedores. Nesse exemplo você está tendo o mesmo problema?

Wendell, eu rodei a que te mandei e realmente funcionou. Mas eu tirei algumas informações da planilha para poder colocar aqui. Por exemplo materiais e preços pagos. Pois são dados da empresa e não gostaria de deixar em aberto para qualquer pessoa ver.

 

Agora rodando com todas as informações ela para no primeiro fornecedor.

 

Pode me passar seu e-mail para que eu te encaminhe o arquivo completo?

Link para o comentário
Compartilhar em outros sites

  • Solução

Eu posso explicar o problema, mas não resolvê-lo.

 

Algumas colunas da sua planilha não respeitam a formatação da coluna. Por exemplo, a coluna AA está formatada como Data, mas valores como "27/04/2015." ou "27/042015." são na verdade textos.

 

Se você selecionar todas as células e formatá-las como texto antes de rodar a marco ela irá funcionar sem erros, mas provavelmente o output no Excel não sairá como deseja.

 

Para contornar isso você pode executar um "Texto para colunas" em cada coluna que deseja reformartar e aplicar o novo formato. No exemplo abaixo fiz isso para as datas da coluna "A" e o pedido concatenado com o item do pedido na coluna "F". O novo código também deleta todos os arquivos da pasta antes de começar a criar os novos.

 

Abs

Sub Send_Emails()Dim Folder As String, HTMLBody As String, Recipient As String, Recipient2 As StringDim FSO As ObjectDim db As DAO.DatabaseDim rs As DAO.Recordset, rs2 As DAO.RecordsetDim c As LongDim OA As Object, OM As ObjectApplication.DisplayAlerts = FalseFolder = "C:\Users\marcur09\Desktop\A\"     HTMLBody = "Prezado Fornecedor,<br>" & _     "<br>" & _"TEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtexto" & _"<br>" & _"<br>Sds."Set FSO = CreateObject("Scripting.FileSystemObject")Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")Set rs = db.OpenRecordset("SELECT DISTINCT [Fornecedor Agrupado] FROM [Plan1$]")Set OA = CreateObject("Outlook.Application")For Each File In FSO.GetFolder(Folder).Files    Kill FileNextWhile Not rs.EOF    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Fornecedor Agrupado]='" & rs(0) & "'")    Workbooks.Add        For c = 0 To rs2.Fields.Count - 1            Cells(1, c + 1) = rs2.Fields(c).Name        Next    Range("A2").CopyFromRecordset rs2    Range("A:A").TextToColumns    Range("A:A").NumberFormat = "dd/mm/yyyy"    Range("F:F").TextToColumns    Range("F:F").NumberFormat = "# ?/?"    Range("A:AZ").EntireColumn.AutoFit    ActiveWorkbook.Close True, Folder & rs(0)    Set OM = OA.CreateItem(0)        With OM            Recipient = db.OpenRecordset("SELECT [E-Mail] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            Recipient2 = db.OpenRecordset("SELECT [Cc] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            .To = Recipient            .CC = Recipient2            .Subject = "Follow-Up - Lista de Pedidos Emitidos Braskem"            .HTMLBody = HTMLBody & "<br>"            .Attachments.Add Folder & rs(0) & ".xlsx"            .Display        End With    rs.MoveNextWendEnd Sub
Link para o comentário
Compartilhar em outros sites

 

Eu posso explicar o problema, mas não resolvê-lo.

 

Algumas colunas da sua planilha não respeitam a formatação da coluna. Por exemplo, a coluna AA está formatada como Data, mas valores como "27/04/2015." ou "27/042015." são na verdade textos.

 

Se você selecionar todas as células e formatá-las como texto antes de rodar a marco ela irá funcionar sem erros, mas provavelmente o output no Excel não sairá como deseja.

 

Para contornar isso você pode executar um "Texto para colunas" em cada coluna que deseja reformartar e aplicar o novo formato. No exemplo abaixo fiz isso para as datas da coluna "A" e o pedido concatenado com o item do pedido na coluna "F". O novo código também deleta todos os arquivos da pasta antes de começar a criar os novos.

 

Abs

Sub Send_Emails()Dim Folder As String, HTMLBody As String, Recipient As String, Recipient2 As StringDim FSO As ObjectDim db As DAO.DatabaseDim rs As DAO.Recordset, rs2 As DAO.RecordsetDim c As LongDim OA As Object, OM As ObjectApplication.DisplayAlerts = FalseFolder = "C:\Users\marcur09\Desktop\A\"     HTMLBody = "Prezado Fornecedor,<br>" & _     "<br>" & _"TEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtextoTEXTOtexto" & _"<br>" & _"<br>Sds."Set FSO = CreateObject("Scripting.FileSystemObject")Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")Set rs = db.OpenRecordset("SELECT DISTINCT [Fornecedor Agrupado] FROM [Plan1$]")Set OA = CreateObject("Outlook.Application")For Each File In FSO.GetFolder(Folder).Files    Kill FileNextWhile Not rs.EOF    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Fornecedor Agrupado]='" & rs(0) & "'")    Workbooks.Add        For c = 0 To rs2.Fields.Count - 1            Cells(1, c + 1) = rs2.Fields(c).Name        Next    Range("A2").CopyFromRecordset rs2    Range("A:A").TextToColumns    Range("A:A").NumberFormat = "dd/mm/yyyy"    Range("F:F").TextToColumns    Range("F:F").NumberFormat = "# ?/?"    Range("A:AZ").EntireColumn.AutoFit    ActiveWorkbook.Close True, Folder & rs(0)    Set OM = OA.CreateItem(0)        With OM            Recipient = db.OpenRecordset("SELECT [E-Mail] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            Recipient2 = db.OpenRecordset("SELECT [Cc] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            .To = Recipient            .CC = Recipient2            .Subject = "Follow-Up - Lista de Pedidos Emitidos Braskem"            .HTMLBody = HTMLBody & "<br>"            .Attachments.Add Folder & rs(0) & ".xlsx"            .Display        End With    rs.MoveNextWendEnd Sub

Você conseguiu rodar Wendell?

 

Agora aparece o email para 3 fornecedores, mas o 4º em diante não. Continua com o mesmo erro e a planilha do 4º fornecedor fica aberta com 151 linhas apenas, que na verdade eram pra ser 2500.

Link para o comentário
Compartilhar em outros sites

De linhas com certena não há limite. De e-mails eu não sei, não me lembro de precisar abrir muitos e-mails.

 

Geralmente eu faço esse tipo de macro até confirmar que está funcionando OK, depois altero a linha

.Display

Para

.Send

Dessa forma o e-mail é enviado sem eu precisar clicar em "Enviar". Já testei com 2.000 e-mails e foram todos enviados sem problemas,

  • Curtir 1
Link para o comentário
Compartilhar em outros sites

De linhas com certena não há limite. De e-mails eu não sei, não me lembro de precisar abrir muitos e-mails.

 

Geralmente eu faço esse tipo de macro até confirmar que está funcionando OK, depois altero a linha

.Display

Para

.Send

Dessa forma o e-mail é enviado sem eu precisar clicar em "Enviar". Já testei com 2.000 e-mails e foram todos enviados sem problemas,

Wendell!!

 

Preciso de uma ultima ajuda sua. Quando envio o email ele não esta vindo com minha assinatura! Procurei muito antes de vir aqui te pedir ajuda, mas não achei. Vale ressaltar que minha assinatura possui imagens.

 

Esse "Function GetSignature" funciona em uma outra macro minha.

 

Consegue me ajudar em mais essa?

Sub Send_Emails()Dim Folder As String, HTMLBody As String, Recipient As String, Recipient2 As StringDim FSO As ObjectDim db As DAO.DatabaseDim rs As DAO.Recordset, rs2 As DAO.RecordsetDim c As LongDim OA As Object, OM As ObjectApplication.DisplayAlerts = FalseFolder = "C:\Users\marcur09\Desktop\A\"     HTMLBody = "Prezado Fornecedor,<br>" & _     "<br>" & _"Estamos enviando uma lista que contém todos os PEDIDOS DE COMPRAS criados e enviados para sua empresa desde o dia 01/01/2015 até a data de hoje, todos os pedidos da lista encontram-se com o status de <b><u>'Não Atendido'</u></b> em nosso sistema, portanto estão atrasados." & _"<br>" & _"Esta planilha será enviada <b><u>mensalmente</u></b> e terá o objetivo de acompanhar a evolução dos atendimentos com a redução dos números de pedidos atrasos, portanto solicitamos que você avalie a lista e informe o motivo pelo qual o pedido ainda não foi faturado e entregue para a XXX, caso o pedido de compras já tenha sido atendido, favor informar na planilha o número da NF e data de emissão da mesma desta forma conseguiremos identificar onde o motivo de sua não digitação." & _"<br>" & _"Abaixo seguem os 'motivos' que deverão ser utilizados para a justificativa do não atendimento, é importante que eles sejam utilizados, pois iremos avaliar de forma padronizada os motivos do não atendimento;" & _"<br>" & _"<p><b>   1- Pedido Recebido - Será atendido" & _"<br>" & _"   2- Pedido Recebido c/ Divergências - Paralisado" & _"<br>" & _"   3- Pedido não recebido" & _"<br>" & _"   4- Pedido já faturado e entregue" & _"<br>" & _"   5- Pedido com solicitação de cancelamento" & _"<br>" & _"   6- Pedido não será atendido - Indicar a causa. </b></p>" & _"<br>" & _"<u>OBS:</u> Para os pedidos de compras onde o motivo do não atendimento for <b><u>'Pedido não recebido'</u></b> justificar na planilha e solicitar ao gestor de seu contrato a envio do mesmo em PDF para que o atendimento seja efetuado. " & _"<br>" & _"<p>A planilha deverá ser retornada para o e-mail  XXX em até 5 dias uteis após o seu recebimento, caso tenha qualquer dúvida em relação ao preenchimento entre em contato pelo fone Tel. +.</p>" & _"<br>" & _"<br>Sds."Set FSO = CreateObject("Scripting.FileSystemObject")Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")Set rs = db.OpenRecordset("SELECT DISTINCT [Fornecedor Agrupado] FROM [Plan1$]")Set OA = CreateObject("Outlook.Application")For Each File In FSO.GetFolder(Folder).Files    Kill FileNextWhile Not rs.EOF    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Fornecedor Agrupado]='" & rs(0) & "'")    Workbooks.Add        For c = 0 To rs2.Fields.Count - 1            Cells(1, c + 1) = rs2.Fields(c).Name        Next    Range("A2").CopyFromRecordset rs2    Range("A:A").TextToColumns    Range("A:A").NumberFormat = "dd/mm/yyyy"    Range("P:P").NumberFormat = "dd/mm/yyyy"    Range("A:AZ").EntireColumn.AutoFit    ActiveWorkbook.Close True, Folder & rs(0)    Set OM = OA.CreateItem(0)        With OM            Recipient = db.OpenRecordset("SELECT [E-Mail] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            Recipient2 = db.OpenRecordset("SELECT [Cc] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            .To = Recipient            .CC = Recipient2            .Subject = "Follow-Up - Lista de Pedidos Emitidos"            .HTMLBody = HTMLBody & "<br>"            .Attachments.Add Folder & rs(0) & ".xlsx"            .Display        End With    rs.MoveNextWendEnd SubFunction Getsignature(ByVal sFile As String) As String Dim FSO As Object Dim ts As Object Set FSO = CreateObject("Scripting.FileSystemObject") Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2) Getsignature = ts.readall ts.Close End Function
Link para o comentário
Compartilhar em outros sites

Marcus,

 

Para enviar os e-mails com assinatura eu faço o seguinte. Crio um e-mail em branco, deixo o texto padrão escrito no corpo dele e salvo na mesma pasta que está a planilha com a macro. Feito isso eu escrevo o código de forma que a macro use esse template para gerar e enviar os e-mails. O código ficaria assim:

Sub Send_Emails()Dim Folder As String, Recipient As String, Recipient2 As StringDim FSO As ObjectDim db As DAO.DatabaseDim rs As DAO.Recordset, rs2 As DAO.RecordsetDim c As LongDim OA As Object, OM As ObjectApplication.DisplayAlerts = FalseFolder = "C:\Users\marcur09\Desktop\A\"Set FSO = CreateObject("Scripting.FileSystemObject")Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")Set rs = db.OpenRecordset("SELECT DISTINCT [Fornecedor Agrupado] FROM [Plan1$]")Set OA = CreateObject("Outlook.Application")For Each File In FSO.GetFolder(Folder).Files    Kill FileNextWhile Not rs.EOF    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Fornecedor Agrupado]='" & rs(0) & "'")    Workbooks.Add        For c = 0 To rs2.Fields.Count - 1            Cells(1, c + 1) = rs2.Fields(c).Name        Next    Range("A2").CopyFromRecordset rs2    Range("A:A").TextToColumns    Range("A:A").NumberFormat = "dd/mm/yyyy"    Range("P:P").NumberFormat = "dd/mm/yyyy"    Range("A:AZ").EntireColumn.AutoFit    ActiveWorkbook.Close True, Folder & rs(0)    Set OM = OA.CreateItemFromTemplate(ThisWorkbook.Path & "\Template.msg")        With OM            Recipient = db.OpenRecordset("SELECT [E-Mail] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            Recipient2 = db.OpenRecordset("SELECT [Cc] FROM [banco_dados$] WHERE [Fornecedor]='" & rs(0) & "'")(0)            .To = Recipient            .CC = Recipient2            .Subject = "Follow-Up - Lista de Pedidos Emitidos"            .Attachments.Add Folder & rs(0) & ".xlsx"            .Display        End With    rs.MoveNextWendEnd Sub

Segue também o template já com o seu texto padrão.

 

 

Template.zip

  • Curtir 1
Link para o comentário
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisa ser um usuário para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...