Kako iz Excela poslati vsak list na različne e-poštne naslove?

Če imate delovni zvezek z več delovnimi listi in je v celici A1 vsakega lista e-poštni naslov. Zdaj želite poslati vsak list iz delovnega zvezka kot prilogo ustreznemu prejemniku v celici A1 posebej. Kako bi lahko rešili to nalogo v Excelu? V tem članku bom predstavil kodo VBA za pošiljanje vsakega lista kot priloge na drug e-poštni naslov iz Excela.

---

Pošljite vsak list na različne e-poštne naslove iz Excela s kodo VBA

Naslednja koda VBA vam lahko pomaga pri pošiljanju vsakega lista kot priloge različnim prejemnikom, naredite takole:

1. Pritisnite Alt + F11 tipke hkrati, da odprete Microsoft Visual Basic za aplikacije okno.

2. Nato kliknite Vstavi > Moduli, ter kopirajte in prilepite spodnjo kodo VBA v okno.

Koda VBA: pošljite vsak list kot prilogo na različne e-poštne naslove

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. Nato pritisnite F5 za zagon te kode in vsak list se samodejno vstavi v okno za novo sporočilo kot priloga, glejte posnetek zaslona:

4. Nazadnje morate le še klikniti Pošlji gumb za pošiljanje vsakega e-poštnega sporočila enega za drugim.