Excel から各シートを別の電子メール アドレスに送信するにはどうすればよいですか?

複数のワークシートを含むワークブックがあり、各シートのセル A1 に電子メール アドレスがある場合。 ここで、ワークブックの各シートをセル A1 の対応する受信者に添付ファイルとして個別に送信したいと考えています。 このタスクを Excel でどのように解決できますか? この記事では、Excel から各シートを別のメール アドレスに添付して送信するための VBA コードを紹介します。

---

VBA コードを使用して Excel から各シートを異なる電子メール アドレスに送信する

次の VBA コードは、各シートを添付ファイルとしてさまざまな受信者に送信するのに役立ちます。次のようにしてください。

1。 押す Alt + F11 キーを同時に開いて アプリケーション向け Microsoft Visual Basic 窓。

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.最後に、クリックするだけです 登録 ボタンをクリックして、各メールを XNUMX つずつ送信します。