跳到主要內容

如何將每張工作表從 Excel 發送到不同的電子郵件地址?

如果您有一個包含多個工作表的工作簿,並且每個工作表的單元格 A1 中都有一個電子郵件地址。 現在,您希望將工作簿中的每張工作表作為附件分別發送給單元格 A1 中的相應收件人。 你怎麼能在 Excel 中解決這個任務? 本文,我將介紹一個 VBA 代碼,用於將每個工作表作為附件從 Excel 發送到不同的電子郵件地址。


使用 VBA 代碼將每張工作表從 Excel 發送到不同的電子郵件地址

以下 VBA 代碼可以幫助您將每張工作表作為附件發送給不同的收件人,請這樣做:

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
備註:在上面的代碼中:
  • S1 是包含您要將電子郵件發送到的電子郵件地址的單元格。 請根據您的需要更改它們。
  • 您可以在代碼中指定自己的CC、BCC、Subject、Body;
  • 要直接發送電子郵件而不打開以下新消息窗口,您需要更改 。顯示。發送.

3。 然後按 F5 運行此代碼的鍵,並且每張工作表都會自動作為附件插入到新消息窗口中,請參見屏幕截圖:

4、最後點擊即可 送出 按鈕逐封發送每封電子郵件。

最佳辦公生產力工具

熱門特色: 尋找、突出顯示或識別重複項   |  刪除空白行   |  合併列或儲存格而不遺失數據   |   沒有公式的回合 ...
超級查詢: 多條件VLookup    多值VLookup  |   跨多個工作表的 VLookup   |   模糊查詢 ....
高級下拉列表: 快速建立下拉列表   |  依賴下拉列表   |  多選下拉列表 ....
欄目經理: 新增特定數量的列  |  移動列  |  切換隱藏列的可見性狀態  |  比較範圍和列 ...
特色功能: 網格焦點   |  設計圖   |   大方程式酒吧    工作簿和工作表管理器   |  資源庫 (自動文字)   |  日期選擇器   |  合併工作表   |  加密/解密單元格    按清單發送電子郵件   |  超級濾鏡   |   特殊過濾器 (過濾粗體/斜體/刪除線...)...
前 15 個工具集12 文本 工具 (添加文本, 刪除字符,...)   |   50+ 圖表 類型 (甘特圖,...)   |   40+ 實用 公式 (根據生日計算年齡,...)   |   19 插入 工具 (插入二維碼, 從路徑插入圖片,...)   |   12 轉化 工具 (數字到單詞, 貨幣兌換,...)   |   7 合併與拆分 工具 (高級合併行, 分裂細胞,...)   |   ... 和更多

使用 Kutools for Excel 增強您的 Excel 技能,體驗前所未有的效率。 Kutools for Excel 提供了 300 多種進階功能來提高生產力並節省時間。  點擊此處獲取您最需要的功能...

kte選項卡201905


Office選項卡為Office帶來了選項卡式界面,使您的工作更加輕鬆

  • 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,Access,Visio和Project。
  • 在同一窗口的新選項卡中而不是在新窗口中打開並創建多個文檔。
  • 將您的工作效率提高 50%,每天為您減少數百次鼠標點擊!
Comments (4)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Does anyone know how to do this exactly but attach Files as PDF Is there an add on code that will convert the Excel to PDF to send via email as well at all. I tried changing the File EXT to .PDF instead of . XLS and .XLSM it attaches a File as PDF but doesn't open the PDF as a recognised File

thanks
This comment was minimized by the moderator on the site
Hello, Jo,
To send the attach files as PDF , please apply the following code:
Sub Mail_Every_Worksheet_As_PDF()
    'Updated by ExtendOffice to send each worksheet as a PDF
    Dim xWs As Worksheet
    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") & "\"
    Set xOlApp = CreateObject("Outlook.Application")
    For Each xWs In ThisWorkbook.Worksheets
        If xWs.Range("A1").Value Like "?*@?*.?*" Then
            xFileName = xWs.Name & " of " _
                         & VBA.Left(ThisWorkbook.Name, VBA.InStr(ThisWorkbook.Name, ".") - 1)
            xWs.Copy
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xTempFilePath & xFileName & ".pdf", Quality:=xlQualityStandard
            
            Set xMailObj = xOlApp.CreateItem(0)
            With xMailObj
                'specify the CC, BCC, Subject, Body below
                .To = xWs.Range("A1").Value
                .CC = ""
                .BCC = ""
                .Subject = "This is the Subject line"
                .Body = "Hi there"
                .Attachments.Add xTempFilePath & xFileName & ".pdf"
                .Display
            End With
            ActiveWorkbook.Close SaveChanges:=False
            Kill xTempFilePath & xFileName & ".pdf"
            Set xMailObj = Nothing
        End If
    Next
    Set xOlApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub


Please have a try, Hope this can help you!
This comment was minimized by the moderator on the site
This works well, just what i was needing. Is there an add on code that will convert the Excel to PDF to send via email as well at all.

thanks
This comment was minimized by the moderator on the site
This is awesome! Thanks for this code!

Only thing I'd like, is there a way to copy values instead of links in the sheets?
There are no comments posted here yet
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations