Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Adapatação Macro E-...
 
Notifications
Clear all

Adapatação Macro E-mail

 
2024 - VBA & Macros
Post Recente por romanholi 8 anos atrás
2 Posts
1 Usuários
0 Reactions
852 Visualizações
RSS
 romanholi
(@romanholi)
Posts: 177
Estimable Member
Topic starter
 

Pessoal, a macro abaixo envia um relatório para um único e-mail!

Preciso que essa macro, entre numa planilha chamada Lst_Emails que na coluna C tem os e-mails listados e envie o mesmo anexo para todos os e-mails listados e não para um único, como na linha abaixo.

Imagino que seja necessário um loop, e trocar a linha abaixo:

.To = "[email protected]"

Mas eu não consigo fazer!

Poderiam me ajudar?

Vide Macro:

Sub Envio_Email()


Dim UltimaLinha As Integer
Dim Email As Integer
Dim K As Integer


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Thisworbook & "Atrasados-" & Format(Now, "dd-mm-yyyy") & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True

        
   
 
    
    
Set MyOlapp = CreateObject("Outlook.Application")
Set myItem = MyOlapp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments





   
With myItem
    .To = "felipe.romanholi@caio.com.br"
    '.CC = "a@a.com.br" 'com cópia
    '.BCC = "" 'com cópia oculta
    .Subject = "Material de Terceiros" & " - " & ActiveSheet.Name
    .Body = "Caro Gestor" & "," & vbCrLf & vbCrLf & _
                    "Segue anexo contendo ""Cronograma Atrasados"" para verificação." & vbCrLf & _
                    "Obrigado - Produção"
                    

    
    .Save
    myAttachments.Add "C:UsersfromanholiDesktopAção e ReaçãoRelatorio_Atrasados.pdf"
    .Send
End With




MsgBox "ENVIADOS COM SUCESSO", vbOKOnly, "AVISO"


End Sub
 
Postado : 08/12/2016 8:50 am
 romanholi
(@romanholi)
Posts: 177
Estimable Member
Topic starter
 

Consegui pessoal!
Não tenho certeza se é a melhor opção... mas funcionou!

Obrigado a todos!
Abraços

Sub Envio_Email()


Dim UltimaLinha As Integer
Dim Email As Integer
Dim k As Integer

Dim rg          As Range
Dim rgValida    As Range
Dim wsEmail     As Worksheet
Dim k1           As Integer



Set wsEmail = Sheets("Lst_Emails")


k1 = wsEmail.Cells(Rows.Count, 3).End(xlUp).Row

With wsEmail
    'Atribui o intervalo de validação à variável rgValida
    Set rgValida = wsEmail.Range("C2:C" & k1)
    
    'Loop para percorrer as células do intervalo de validação
    For Each rg In rgValida
        
    'Testar se a célula rg está preenchida
        If rg.Value <> 0 Then

        
             
    
Set MyOlapp = CreateObject("Outlook.Application")
Set myItem = MyOlapp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments




   
With myItem
    .To = rg.Value
    '.CC = "a@a.com.br" 'com cópia
    '.BCC = "" 'com cópia oculta
    .Subject = "Material de Terceiros" & " - " & ActiveSheet.Name
    .Body = "Caro Gestor" & "," & vbCrLf & vbCrLf & _
                    "Segue anexo contendo ""Cronograma Atrasados"" para verificação." & vbCrLf & _
                    "Obrigado - Produção"
                    

    
    .Save
    myAttachments.Add "C:UsersfromanholiDesktopAção e ReaçãoRelatorio_Atrasados.pdf"
    .Send
End With

            End If
    Next rg
End With


MsgBox "ENVIADOS COM SUCESSO", vbOKOnly, "AVISO"


End Sub
 
Postado : 08/12/2016 11:38 am
Forum Jump:
  Tópico Anterior
Próximo Tópico