Jak wysłać każdy arkusz na różne adresy e-mail z programu Excel?

Jeśli masz skoroszyt z kilkoma arkuszami, a w komórce A1 każdego arkusza znajduje się adres e-mail. Teraz chcesz wysłać każdy arkusz ze skoroszytu jako załącznik do odpowiedniego odbiorcy w komórce A1 indywidualnie. Jak mogłeś rozwiązać to zadanie w programie Excel? W tym artykule przedstawię kod VBA, aby wysłać każdy arkusz jako załącznik na inny adres e-mail z programu Excel.

---

Wyślij każdy arkusz na różne adresy e-mail z programu Excel za pomocą kodu VBA

Poniższy kod VBA może pomóc w wysłaniu każdego arkusza jako załącznika do różnych odbiorców, wykonaj następujące czynności:

1. naciśnij Alt + F11 klawisze jednocześnie, aby otworzyć Microsoft Visual Basic for Applications okno.

2. Następnie kliknij wstawka > Modułi skopiuj i wklej poniższy kod VBA do okna.

Kod VBA: wyślij każdy arkusz jako załącznik na różne adresy 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. Następnie naciśnij F5 klucz, aby uruchomić ten kod, a każdy arkusz jest automatycznie wstawiany do nowego okna wiadomości jako załącznik, patrz zrzut ekranu:

4. Na koniec wystarczy kliknąć Wyślij przycisk, aby wysłać każdy e-mail jeden po drugim.