Her sayfa Excel'den farklı e-posta adreslerine nasıl gönderilir?

Birkaç çalışma sayfası içeren bir çalışma kitabınız varsa ve her sayfanın A1 hücresinde bir e-posta adresi varsa. Şimdi, çalışma kitabındaki her sayfayı ek olarak A1 hücresindeki ilgili alıcıya ayrı ayrı göndermek istiyorsunuz. Bu görevi Excel'de nasıl çözebilirsiniz? Bu makalede, her sayfayı Excel'den farklı bir e-posta adresine ek olarak göndermek için bir VBA kodu tanıtacağım.

---

Her sayfayı VBA koduyla Excel'den farklı e-posta adreslerine gönderin

Aşağıdaki VBA kodu, her sayfayı ek olarak farklı alıcılara göndermenize yardımcı olabilir, lütfen şu şekilde yapın:

1. Basın Alt + F11 anahtarları aynı anda açmak için Uygulamalar için Microsoft Visual Basic pencere.

2. Daha sonra, Ekle > modül, ve aşağıdaki VBA kodunu kopyalayıp pencereye yapıştırın.

VBA kodu: Her sayfayı farklı e-posta adreslerine ek olarak gönderin

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. Daha sonra, tuşuna basın. F5 tuşuna basın ve her sayfa otomatik olarak ek olarak yeni mesaj penceresine eklenir, ekran görüntüsüne bakın:

4. Son olarak, tıklamanız yeterlidir Gönder her e-postayı tek tek göndermek için düğme.