[英]How to send personalized emails from Excel?
我有一個經理姓名列表和未提交時間表的員工的電子郵件地址。 我需要一個代碼來創建發送給每個經理的電子郵件,其中包含未提交時間表的員工的姓名。 有什么建議嗎? 該文件如下所示
approval name Approval Email address Employee name
test 1 test@yahoo Test 11
test 2 test@hotmail.com test 10
test 3 test@gmail.com test 9
如何更改代碼以發送給每個成員而不是一封電子郵件
sub sendmultiple()
'
Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim xRg As Range
Dim xEmailAddr As String
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the addresses list:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOTApp = CreateObject("Outlook.Application")
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
Set xMItem = xOTApp.CreateItem(0)
With xMItem
.To = xEmailAddr
.Display
End With
End Sub
由於這看起來像是作業,因此我將為您提供一個非功能性的示例,向您展示總體結構
Sub sendmultiple()
Dim lRow As Long
Dim oMailItem As Object
lRow = 2
[code to create Outlook application object goes here]
Do Until Range("A" & lRow) = ""
[code to Set oMailItem goes here]
With oMailItem
.To = Range("B" & lRow) ' the email address it goes to
.Subject = Range("A" & lRow) ' the name of approval person, not sure why
.HTMLBody = Range("C" & lRow) ' the person the email is about
.Send
End With
lRow = lRow + 1
Loop
End Sub
進行較小的修改,您就應該能夠完全按照您的要求進行操作。
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.