Como enviar cada planilha para diferentes endereços de e-mail do Excel?

Se você tiver uma pasta de trabalho com várias planilhas e houver um endereço de email na célula A1 de cada planilha. Agora, você deseja enviar cada planilha da pasta de trabalho como um anexo para o destinatário correspondente na célula A1 individualmente. Como você poderia resolver essa tarefa no Excel? Neste artigo, apresentarei um código VBA para enviar cada planilha como anexo para um endereço de e-mail diferente do Excel.

---

Envie cada planilha para diferentes endereços de e-mail do Excel com código VBA

O código VBA a seguir pode ajudá-lo a enviar cada planilha como um anexo para diferentes destinatários, faça o seguinte:

1. pressione Alt + F11 simultaneamente para abrir o Microsoft Visual Basic para Aplicações janela.

2. Então clique inserção > Módulo, e copie e cole o código VBA abaixo na janela.

Código VBA: envie cada planilha como anexo para diferentes endereços de e-mail

Sub Mail_Every_Worksheet()
'Updateby ExtendOffice
  Dim xWs As Worksheet
  Dim xWb As Workbook
  Dim xFileExt As String
  Dim xFileFormatNum As Long
  Dim xTempFilePath As String
  Dim xFileName As String
  Dim xOlApp As Object
  Dim xMailObj As Object
  On Error Resume Next
  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With
  xTempFilePath = Environ$("temp") & "\"
  If Val(Application.Version) < 12 Then
    xFileExt = ".xls": xFileFormatNum = -4143
  Else
    xFileExt = ".xlsm": xFileFormatNum = 52
  End If
  Set xOlApp = CreateObject("Outlook.Application")
  For Each xWs In ThisWorkbook.Worksheets
    If xWs.Range("S1").Value Like "?*@?*.?*" Then
      xWs.Copy
      Set xWb = ActiveWorkbook
      xFileName = xWs.Name & " of " _
                   & VBA.Left(ThisWorkbook.Name, VBA.InStr(ThisWorkbook.Name, ".") - 1) & " "
      Set xMailObj = xOlApp.CreateItem(0)
      xWb.Sheets.Item(1).Range("S1").Value = ""
      With xWb
        .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
        With xMailObj
        'specify the CC, BCC, Subject, Body below
            .To = xWs.Range("S1").Value
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add xWb.FullName
            .Display
        End With
        .Close SaveChanges:=False
      End With
      Set xMailObj = Nothing
      Kill xTempFilePath & xFileName & xFileExt
    End If
  Next
  Set xOlApp = Nothing
  With Application
      .ScreenUpdating = True
      .EnableEvents = True
  End With
End Sub

3. Então aperte F5 key para executar este código, e cada planilha é inserida na nova janela de mensagem como um anexo automaticamente, veja a captura de tela:

4. Por fim, basta clicar ENVIAR botão para enviar cada e-mail um por um.