Excel macro envio de emails

[djacy.neto]

pessoal tenho uma macro para enviar emails, e o que esta acontecendo é:

cada email tem um anexo, mais ele esta juntando os anexos ao enviar.

ele deve enviar email1 anexo1, email2 anexo2,

e esta enviando assim email1 anexo1 email2 anexo1 anexo2...

e a cada email ele vai agrupando os anexos.

segue codigo abaixo:

 Sheets("Geral").Select
   ActiveSheet.Range("c38:ao75").Select
   Application.CutCopyMode = False
   Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        
   ActiveWorkbook.EnvelopeVisible = True
  
   With ActiveSheet.MailEnvelope
    .Introduction = "Boa tarde!" + vbCrLf + " " + vbCrLf + "Segue quadro"
    .Item.to = "[email protected]"
    .Item.Cc = "[email protected]"
    .Item.Subject = "assunto"
    .Item.Attachments.Add "P:\arquivo.xlsx"
    .Item.Send

excel 2019

[Visitante]

 

Disponibilize o código inteiro.

[djacy.neto]

@osvaldomp esse é o codigo, a unica coisa que eu faco é replicar 

 

 Sheets("Geral").Select
   ActiveSheet.Range("c38:ao75").Select
   Application.CutCopyMode = False
   Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        
   ActiveWorkbook.EnvelopeVisible = True
  
   With ActiveSheet.MailEnvelope
    .Introduction = "Boa tarde!" + vbCrLf + " " + vbCrLf + "Segue quadro"
    .Item.to = "[email protected]"
    .Item.Cc = "[email protected]"
    .Item.Subject = "assunto"
    .Item.Attachments.Add "P:\arquivo1.xlsx"
    .Item.Send
   end with

 Sheets("Geral").Select
   ActiveSheet.Range("c38:ao75").Select
   Application.CutCopyMode = False
   Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        
   ActiveWorkbook.EnvelopeVisible = True
  
   With ActiveSheet.MailEnvelope
    .Introduction = "Boa tarde!" + vbCrLf + " " + vbCrLf + "Segue quadro"
    .Item.to = "[email protected]"
    .Item.Cc = "[email protected]"
    .Item.Subject = "assunto"
    .Item.Attachments.Add "P:\arquivo2.xlsx"
    .Item.Send
   end with

 Sheets("Geral").Select
   ActiveSheet.Range("c38:ao75").Select
   Application.CutCopyMode = False
   Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        
   ActiveWorkbook.EnvelopeVisible = True
  
   With ActiveSheet.MailEnvelope
    .Introduction = "Boa tarde!" + vbCrLf + " " + vbCrLf + "Segue quadro"
    .Item.to = "[email protected]"
    .Item.Cc = "[email protected]"
    .Item.Subject = "assunto"
    .Item.Attachments.Add "P:\arquivo3.xlsx"
    .Item.Send
   end with
end sub

o que muda sao os anexos e os emails destino..

[Visitante]

 

Em cada trecho do código que envia um email acrescente as 3 linhas em vermelho conforme abaixo.

 

   .Item.Subject = "assunto"
    On Error Resume Next
    .Item.Attachments(1).Delete
    On Error GoTo 0
    .Item.Attachments.Add "P:\arquivo1.xlsx"