Как отправить каждый лист на разные адреса электронной почты из Excel?

Если у вас есть книга Excel с несколькими листами, каждый из которых содержит адрес электронной почты в ячейке S1, вы можете захотеть отправить каждый лист как отдельное вложение соответствующему получателю. Эта задача может быть утомительной, если выполнять её вручную, особенно при работе с большим количеством листов. В этом руководстве мы покажем вам, как использовать код VBA для автоматической отправки каждого листа из вашего файла Excel в виде вложения на адрес электронной почты, указанный в ячейке S1 каждого листа.

Отправка каждого листа на разные адреса электронной почты из Excel с помощью кода VBA

Следующий код VBA позволит вам отправлять каждый лист как вложение соответствующему получателю, указанному в ячейке S1. Пожалуйста, следуйте этим шагам:

1. Нажмите клавиши Alt+ F11 одновременно, чтобы открыть окно Microsoft Visual Basic for Applications.

2. Затем нажмите Вставить > Модуль и скопируйте и вставьте приведенный ниже код VBA в окно.

Код VBA: Отправить каждый лист как вложение на разные адреса электронной почты

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. Затем нажмите клавишу F5, чтобы запустить этот код, и каждый лист будет автоматически вставлен в новое окно сообщения как вложение, см. скриншот:

4. Наконец, нажмите кнопку Отправить, чтобы отправить каждое письмо одно за другим.

Kutools для Excel: Легко отправляйте персонализированные электронные письма одним щелчком!

Устали отправлять клиентам электронные письма по одному? С функцией «Отправить письмо» в Kutools для Excel общение становится быстрее и профессиональнее! Просто подготовьте таблицу Excel с именами, адресами электронной почты, регистрационными кодами и вставьте заполнители — система автоматически создаст персонализированные письма и отправит сотни одним щелчком. Забудьте о рутинной работе!

• 💡 Динамические заполнители (например, имя, регистрационный код) автоматически заполняют персонализированное содержимое для каждого получателя, делая каждое письмо уникальным.
• 📎 Прикрепите персонализированные файлы для точной доставки
• 📤 Плавная интеграция с Outlook для безопасной и надежной отправки
• 📝 Сохраняйте и повторно используйте шаблоны электронных писем для максимальной эффективности
• 🎨 Простой в использовании редактор WYSIWYG (что видишь, то и получаешь)
• 🖋 Использует вашу подпись в Outlook — никаких дополнительных настроек, просто нажмите отправить!
• Получите Kutools для Excel прямо сейчас!