Hogyan küldhetek el minden egyes lapot különböző e-mail címekre az Excelből?

Ha van egy munkafüzete több munkalappal, és minden lap A1 cellájában van egy e-mail cím. Most a munkafüzet minden egyes lapját mellékletként szeretné elküldeni az A1 cellában lévő megfelelő címzettnek. Hogyan tudnád megoldani ezt a feladatot Excelben? Ebben a cikkben bemutatok egy VBA-kódot, amellyel minden egyes lapot csatolmányként elküldhetek az Excel különböző e-mail-címére.

---

Küldje el az egyes lapot különböző e-mail címekre az Excelből VBA-kóddal

A következő VBA-kód segíthet az egyes lapok mellékletként történő elküldésében különböző címzetteknek, kérjük, tegye a következőket:

1. nyomja meg Alt + F11 gombok egyszerre a Microsoft Visual Basic for Applications ablak.

2. Ezután kattints a gombra betétlap > Modulok, majd másolja és illessze be az alábbi VBA-kódot az ablakba.

VBA-kód: Küldje el az egyes lapot mellékletként különböző e-mail címekre

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. Ezután nyomja meg a gombot F5 gombot a kód futtatásához, és minden egyes lap automatikusan csatolmányként bekerül az új üzenetablakba, lásd a képernyőképet:

4. Végül csak kattintani kell Küldés gombot az egyes e-mailek elküldéséhez.