Excel宏在多個獨立的電子郵件中發送特定信息

所以我需要一些幫助。我正在嘗試更新我們公司用於管理客戶端的Excel工具。我目前需要幫助更新工具的發送電子郵件功能。因此，員工將擁有他們需要發送電子郵件的客戶列表，並且每個客戶都將擁有特定的信息，如姓名，客戶編號等，員工應能夠單擊內置的「發送電子郵件」宏按鈕，並且不同的電子郵件將在Outlook中填入電子郵件收件人，標題和正文內置的每個客戶端的特定信息。Excel宏在多個獨立的電子郵件中發送特定信息

我目前卡住了。例如，我將選擇3個客戶端發送電子郵件到，點擊「發送電子郵件」按鈕，我會得到3封電子郵件（我應該）。第一封電子郵件將在正確的地方爲客戶＃1提供所有正確的信息。但是，電子郵件＃2將具有正確的電子郵件收件人&電子郵件標題，但電子郵件正文將具有正確的信息給客戶端＃2，並且在電子郵件正文中也將是客戶端＃1的所有電子郵件正文信息。電子郵件＃3也是一樣的，它將具有正確的收件人和標題，但正文將具有客戶端＃3，客戶端＃2和客戶端＃1的正文信息。

所以我知道我需要通過電子郵件正文的某種循環來修復它，但我一直在研究這個問題很久我就再也看不到它了。我刪除了所有敏感信息並放入佔位符，但我認爲您應該明白。

如果您有任何問題，請讓我知道。

Sub SendEMail() 
Dim Email As String 
Dim Subj As String 
Dim Msg As String 
Dim URL As String 
Dim r As Integer 
Dim x As Double 
Dim OApp As Object 
Dim OMail As Variant 
Dim Signature As String 
Dim strbody As String 



strbody = "<html><body>" 

With Sheets("Email").Select 
lastrow = Cells(Rows.Count, "B").End(xlUp).Row 
End With 

For r = 2 To lastrow 


Set OApp = CreateObject("Outlook.Application") 
Set OMail = OApp.CreateItem(0) 

'  Get the email address 
Sheets("Email").Select 
Email = Cells(r, "F") 
'  Message subject 
Sheets("Email").Select 
Subj = "Renewal for " & Cells(r, "B").Text & " Contract " & Cells(r, "A").Text & " Effective " & Cells(r, "C").Text 

'  Message body 
Sheets("Email").Select 
strbody = strbody & "Dear " & Cells(r, "AR").Text & ", <br><br>" & _ 
"I will be working with you on " & Cells(r, "B") & ", client number " &  Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _ 
"For this year's contract, we are requesting the following information: <br>" & _ 
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _ 
"The application form may be downloaded from:<br>" & _ 
"<li>Option #1</li>: " & "<a href=""" & "Link#1" & """>" & "Link#1" & "</a>" & "<br>" & _ 
"<li>Option #2</li>: " & "<a href=""" & "link#2" & """>" & "link#2" & "</a>" & "<br><br>" & _ 
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _ 
"As always, we would like to thank you for your business. <br><br>" & _ 
"Regards, <br>" 

On Error Resume Next 

Sheets("Email").Select 
With OMail 
.Display 
.To = Email 
.Subject = Subj 
.HTMLBody = strbody & vbNewLine & .HTMLBody 
End With 
Next r 

On Error GoTo 0 

Set OMail = Nothing 
Set OApp = Nothing 

End Sub

來源

2016-05-31 newkid59

有點像[郵件合併]（https://support.office.com/en-us/article/Use-mail-merge-to-send-personalized-email-messages-to- your-email-address-list-c49e5cfc-53f9-4ec8-9bd9-1f8f3648f1b7？ui = zh-CN＆rs = zh-CN＆ad = US） – gtwebb

-1

如果你想使用這個宏，而不是郵件合併您所遇到的問題是在這裏：

strbody = strbody & "Dear " & Cells(r, "AR").Text & ", <br><br>" & _ 
"I will be working with you on " & Cells(r, "B") & ", client number " &  Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _ 
"For this year's contract, we are requesting the following information: <br>" & _ 
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _ 
"The application form may be downloaded from:<br>" & _ 
"<li>Option #1</li>: " & "<a href=""" & "Link#1" & """>" & "Link#1" & "</a>" & "<br>" & _ 
"<li>Option #2</li>: " & "<a href=""" & "link#2" & """>" & "link#2" & "</a>" & "<br><br>" & _ 
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _ 
"As always, we would like to thank you for your business. <br><br>" & _ 
"Regards, <br>"

這需要變量strbody和增加的字符串的其餘部分給它。

更新它：

strbody = "Dear " & Cells(r, "AR").Text & ", <br><br>" & _ 
"I will be working with you on " & Cells(r, "B") & ", client number " &  Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _ 
"For this year's contract, we are requesting the following information: <br>" & _ 
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _ 
"The application form may be downloaded from:<br>" & _ 
"<li>Option #1</li>: " & "<a href=""" & "Link#1" & """>" & "Link#1" & "</a>" & "<br>" & _ 
"<li>Option #2</li>: " & "<a href=""" & "link#2" & """>" & "link#2" & "</a>" & "<br><br>" & _ 
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _ 
"As always, we would like to thank you for your business. <br><br>" & _ 
"Regards, <br>"

它將每個這就是我想你想的時間覆蓋。

此外，您不需要每次選擇工作表（或根本不需要）。選擇工作表，單元格等通常是不好的編碼習慣，會顯着減慢你的代碼。

來源

2016-05-31 19:47:07 gtwebb

是的，這很好！非常感謝您的幫助和建議！我是一名初學者，所以在我形成壞習慣之前，這些技巧都很棒。感謝您如此高效！ – newkid59

不知道downvote是什麼，因爲它似乎解決了OP的問題，儘管它沒有被接受。 – gtwebb

請看看這個例子。

在列A：E-mail地址在C列：人民在B列的名稱Z：文件名類似這樣的C：\ DATA \ Book2.xls中（不必是Excel文件）

宏將循環顯示「Sheet1」中的每一行，如果列B 中有電子郵件地址，並且列C：Z中的文件名將會創建一封包含此信息的郵件併發送。

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

您可以通過下面的鏈接瞭解關於它的更多信息。

http://www.rondebruin.nl/win/s1/outlook/amail6.htm

來源

2016-06-02 15:44:04 ryguy7272

Excel宏在多個獨立的電子郵件中發送特定信息

回答

相關問題