VBA Excel发送个人电子邮件_Vba_Excel_Email

VBA Excel发送个人电子邮件

vba excel email

VBA Excel发送个人电子邮件,vba,excel,email,Vba,Excel,Email,我有下面的代码，对我来说非常好。它将“名称”列（第I列）中的名称进行比较，根据其他单元格（L、K）中的条件生成电子邮件列表，并生成包含工作表中某些内容的邮件正文，以便我可以将其发送到收件人列表我现在有一个要求，发送它在个人电子邮件，而不是一封电子邮件，是发送给每个人。我现在可以通过用名字过滤列I来做到这一点，但是如果有大约100个名字，这有点烦人。。。有没有办法修改代码，让它为收件人生成单独的电子邮件 p、谢谢，代码可能有点混乱/没有优化，但我是个新手…谢谢 Sub SendEmail()

我有下面的代码，对我来说非常好。它将“名称”列（第I列）中的名称进行比较，根据其他单元格（L、K）中的条件生成电子邮件列表，并生成包含工作表中某些内容的邮件正文，以便我可以将其发送到收件人列表

我现在有一个要求，发送它在个人电子邮件，而不是一封电子邮件，是发送给每个人。我现在可以通过用名字过滤列I来做到这一点，但是如果有大约100个名字，这有点烦人。。。有没有办法修改代码，让它为收件人生成单独的电子邮件

p、谢谢，代码可能有点混乱/没有优化，但我是个新手…谢谢

Sub SendEmail()

    Dim OutlookApp
    Dim MItem
    Dim cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Recipient As String
    Dim Msg As String
    Dim Projects As String
    Dim ProjectsMsg As String


    'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set MItem = OutlookApp.CreateItem(0)
    'Loop through the rows
    For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
     If cell.Value <> "" And _
           (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then
            'first build email address
            EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com"
            'then check if it is in Recipient List build, if not, add it, otherwise ignore
            If InStr(1, Recipient, EmailAddr) = 0 Then Recipient = Recipient & ";" & EmailAddr
        End If
    Next


    Recipient = Mid(Recipient, 2) 

For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeVisible)
     If cell.Value <> "" And _
           (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" And _
           (Cells(cell.Row, "I").Value) <> "" Then
             Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value
             If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf
        End If
Next
    Msg = "Please review the following: " & ProjectMsg
    Subj = "Outstanding Documents to be Reviewed"
    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = Recipient 'full recipient list
        .Subject = Subj
        .Body = Msg
        .display
    End With

End Sub

Sub sendmail（）
昏暗的观景应用程序
暗斜纹
暗淡单元格作为范围
将sub设置为字符串
Dim EmailAddr作为字符串
将收件人设置为字符串
作为字符串的Dim Msg
将项目设置为字符串
Dim ProjectsMsg As字符串
'创建Outlook对象
设置OutlookApp=CreateObject（“Outlook.Application”）
设置MItem=OutlookApp.CreateItem（0）
'在行中循环
对于列（“I”）.Cells.SpecialCells（xlCellTypeVisible）中的每个单元格
如果单元格的.Value为“”，则_
（Cells（cell.Row，“L”）.Value）=“否”，然后（Cells（cell.Row，“K”）.Value）“是”
'第一个生成电子邮件地址
EmailAddr=LCase$（替换（cell.Value，“，”）&“@company.com”
'然后检查它是否在收件人列表生成中，如果不在，则添加它，否则忽略
如果InStr（1，Recipient，EmailAddr）=0，则Recipient=Recipient&“；”和EmailAddr
如果结束
下一个
收件人=Mid（收件人，2）
对于列（“C”）.Cells.SpecialCells（xlCellTypeVisible）中的每个单元格
如果单元格的.Value为“”，则_
（单元格（cell.Row，“L”）.值）=“否”和（单元格（cell.Row，“K”）.值）“是”和_
（Cells（cell.Row，“I”）.Value）”，然后
Projects=vbCrLf&“Document:”&单元格（cell.Row，“B”）。Value&“；”&单元格（cell.Row，“C”）。Value&“；”和“Rev”&单元格（cell.Row，“G”）。Value&“；”和单元格（cell.Row，“I”）。Value
如果InStr（1，ProjectsMsg，Projects）=0，则ProjectsMsg=ProjectsMsg&Projects&vbCrLf
如果结束
下一个
Msg=“请检查以下内容：”&ProjectMsg
sub=“待审核的未完成文件”
'发送前创建邮件项目并查看
设置MItem=OutlookApp.CreateItem（olMailItem）
含螨
.To=收件人的完整收件人列表
主语，主语
.Body=Msg
.展示
以
端接头

我认为您希望做的是将收件人列表放入电子邮件中，然后让电子邮件为每个人生成不同的电子邮件。它不像这样工作

相反，移动代码使电子邮件进入循环，以便每次生成一封新电子邮件并发送。先创建项目Msg，然后再创建主题，这样他们就可以发送电子邮件了

Sub SendEmail()

Dim OutlookApp
Dim MItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim PriorRecipients As String
Dim Msg As String
Dim Projects As String
Dim ProjectsMsg As String


'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
PriorRecipients = ""

'First create the body for the message
 For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeVisible)
      If cell.Value <> "" And _
       (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" And _
       (Cells(cell.Row, "I").Value) <> "" Then
              Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value
              If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf
        End If
 Next

Msg = "Please review the following: " & ProjectMsg
Subj = "Outstanding Documents to be Reviewed"

'Loop through each person and send email if they haven't already received one.
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
     If cell.Value <> "" And _
       (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then
        'first build email address
        EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com"
        'then check if it is in Recipient List build, if not, add it, otherwise ignore
         'If the recipient has already received an email, skip
         If InStr(1, PriorRecipients, EmailAddr) <> 0 Then 
             GoTo NextRecipient              
         End If

         PriorRecipients = PriorRecipients & ";" & EmailAddr
         'Create Mail Item and view before sending
         Set MItem = OutlookApp.CreateItem(olMailItem)
         With MItem
              .To = EmailAddr 'single email address
              .Subject = Subj
              .Body = Msg
              .display 
              'This will show for EVERY person.  Skip this and change to .send to just send without showing the email.
         End With
      End If
 NextRecipient:

 Next

End Sub

Sub sendmail（）
昏暗的观景应用程序
暗斜纹
暗淡单元格作为范围
将sub设置为字符串
Dim EmailAddr作为字符串
模糊的优先属性，如字符串
作为字符串的Dim Msg
将项目设置为字符串
Dim ProjectsMsg As字符串
'创建Outlook对象
设置OutlookApp=CreateObject（“Outlook.Application”）
PriorRecipients=“”
'首先创建邮件的正文
对于列（“C”）.Cells.SpecialCells（xlCellTypeVisible）中的每个单元格
如果单元格的.Value为“”，则_
（单元格（cell.Row，“L”）.值）=“否”和（单元格（cell.Row，“K”）.值）“是”和_
（Cells（cell.Row，“I”）.Value）”，然后
Projects=vbCrLf&“Document:”&单元格（cell.Row，“B”）。Value&“；”&单元格（cell.Row，“C”）。Value&“；”和“Rev”&单元格（cell.Row，“G”）。Value&“；”和单元格（cell.Row，“I”）。Value
如果InStr（1，ProjectsMsg，Projects）=0，则ProjectsMsg=ProjectsMsg&Projects&vbCrLf
如果结束
下一个
Msg=“请检查以下内容：”&ProjectMsg
sub=“待审核的未完成文件”
“对每个人进行循环，如果他们还没有收到电子邮件，就发送电子邮件。
对于列（“I”）.Cells.SpecialCells（xlCellTypeVisible）中的每个单元格
如果单元格的.Value为“”，则_
（Cells（cell.Row，“L”）.Value）=“否”，然后（Cells（cell.Row，“K”）.Value）“是”
'第一个生成电子邮件地址
EmailAddr=LCase$（替换（cell.Value，“，”）&“@company.com”
'然后检查它是否在收件人列表生成中，如果不在，则添加它，否则忽略
'如果收件人已收到电子邮件，请跳过
如果InStr（1，PriorRecipients，EmailAddr）为0，则
转到下一个客户
如果结束
PriorRecipients=PriorRecipients&“；”和EmailAddr
'发送前创建邮件项目并查看
设置MItem=OutlookApp.CreateItem（olMailItem）
含螨
.To=EmailAddr'单个电子邮件地址
主语，主语
.Body=Msg
.展示
"这对每一个人来说都是可以证明的。跳过此操作并更改为。发送到只发送而不显示电子邮件。
以
如果结束
下一位客户：
下一个
端接头

我认为您希望做的是将收件人列表放入电子邮件中，然后让电子邮件为每个人生成不同的电子邮件。它不像这样工作

相反，移动代码使电子邮件进入循环，以便每次生成一封新电子邮件并发送。先创建项目Msg，然后再创建主题，这样他们就可以发送电子邮件了

Sub SendEmail()

Dim OutlookApp
Dim MItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim PriorRecipients As String
Dim Msg As String
Dim Projects As String
Dim ProjectsMsg As String


'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
PriorRecipients = ""

'First create the body for the message
 For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeVisible)
      If cell.Value <> "" And _
       (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" And _
       (Cells(cell.Row, "I").Value) <> "" Then
              Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value
              If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf
        End If
 Next

Msg = "Please review the following: " & ProjectMsg
Subj = "Outstanding Documents to be Reviewed"

'Loop through each person and send email if they haven't already received one.
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
     If cell.Value <> "" And _
       (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then
        'first build email address
        EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com"
        'then check if it is in Recipient List build, if not, add it, otherwise ignore
         'If the recipient has already received an email, skip
         If InStr(1, PriorRecipients, EmailAddr) <> 0 Then 
             GoTo NextRecipient              
         End If

         PriorRecipients = PriorRecipients & ";" & EmailAddr
         'Create Mail Item and view before sending
         Set MItem = OutlookApp.CreateItem(olMailItem)
         With MItem
              .To = EmailAddr 'single email address
              .Subject = Subj
              .Body = Msg
              .display 
              'This will show for EVERY person.  Skip this and change to .send to just send without showing the email.
         End With
      End If
 NextRecipient:

 Next

End Sub

Sub sendmail（）
昏暗的观景应用程序
暗斜纹
暗淡单元格作为范围
将sub设置为字符串
Dim EmailAddr作为字符串
模糊的优先属性，如字符串
作为字符串的Dim Msg
将项目设置为字符串
Dim ProjectsMsg As字符串
'创建Outlook对象
设置OutlookApp=CreateObject（“Outlook.Application”）
PriorRecipients=“”
'首先创建邮件的正文
对于列（“C”）.Cells.SpecialCells（xlCellTypeVisible）中的每个单元格
如果单元格的.Value为“”，则_
（单元格（cell.Row，“L”）.值）=“否”和（单元格（c