Jak odeslat každý list na různé e-mailové adresy z Excelu?
Pokud máte sešit s několika listy a v buňce A1 každého listu je e-mailová adresa. Nyní chcete odeslat každý list ze sešitu jako přílohu příslušnému příjemci v buňce A1 jednotlivě. Jak byste mohli vyřešit tento úkol v Excelu? V tomto článku představím kód VBA pro odeslání každého listu jako přílohy na jinou e-mailovou adresu z aplikace Excel.
Odešlete každý list na různé e-mailové adresy z Excelu s kódem VBA
Následující kód VBA vám může pomoci odeslat každý list jako přílohu různým příjemcům, postupujte takto:
1. lis Alt + F11 současně otevřete Microsoft Visual Basic pro aplikace okno.
2. Potom klepněte na tlačítko Vložit > Modula zkopírujte a vložte níže uvedený kód VBA do okna.
Kód VBA: Odešlete každý list jako přílohu na různé e-mailové adresy
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 je buňka obsahuje e-mailovou adresu, na kterou chcete odeslat e-mail. Změňte je prosím podle svých potřeb.
- V kódu můžete zadat kopii, skrytou kopii, předmět, tělo podle svého;
- Chcete-li odeslat e-mail přímo bez otevření následujícího okna nové zprávy, musíte provést změnu .Zobrazit na .Poslat.
3. Poté stiskněte tlačítko F5 klíč ke spuštění tohoto kódu a každý list se automaticky vloží do okna nové zprávy jako příloha, viz snímek obrazovky:
4. Nakonec stačí kliknout Poslat tlačítko pro odeslání každého e-mailu jeden po druhém.
Nejlepší nástroje pro produktivitu v kanceláři
Rozšiřte své dovednosti Excel pomocí Kutools pro Excel a zažijte efektivitu jako nikdy předtím. Kutools for Excel nabízí více než 300 pokročilých funkcí pro zvýšení produktivity a úsporu času. Kliknutím sem získáte funkci, kterou nejvíce potřebujete...
Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci
- Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
- Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
- Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!