Hoe elk blad vanuit Excel naar verschillende e-mailadressen verzenden?

Als u een werkmap hebt met meerdere werkbladen en er is een e-mailadres in cel A1 van elk blad. Nu wilt u elk blad uit de werkmap als bijlage afzonderlijk naar de bijbehorende ontvanger in cel A1 sturen. Hoe zou je deze taak in Excel kunnen oplossen? In dit artikel zal ik een VBA-code introduceren om elk blad als bijlage naar een ander e-mailadres vanuit Excel te verzenden.

---

Stuur elk blad naar verschillende e-mailadressen vanuit Excel met VBA-code

De volgende VBA-code kan u helpen om elk blad als bijlage naar verschillende ontvangers te verzenden, doe dit als volgt:

1. pers Alt + F11 toetsen tegelijkertijd om het Microsoft Visual Basic voor toepassingen venster.

2. Dan klikken Invoegen > Module, en kopieer en plak de onderstaande VBA-code in het venster.

VBA-code: stuur elk blad als bijlage naar verschillende e-mailadressen

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. Druk vervolgens op F5 toets om deze code uit te voeren, en elk blad wordt automatisch als bijlage in het nieuwe berichtvenster ingevoegd, zie screenshot:

4. Ten slotte hoeft u alleen maar te klikken Verzenden knop om elke e-mail één voor één te verzenden.