使用VBA发送电子邮件到Excel上的电子邮件列表

已经写好了我写的VBA代码的90％，只需要添加以下内容。我的宏几乎运行并且如果声明，并且如果某个条件适用，它将通过电子邮件发送到某个地址。我需要做的是运行if语句，如果它满足一定的条件，将它发送到4-5封电子邮件（可能更多）的列表，这是在同一个工作簿中，但是标题为“电子邮件列表”。使用VBA发送电子邮件到Excel上的电子邮件列表

可以忽略的顶部，这就是我目前的工作。

这是更新的代码。请告知，因为有8个部分，那么我将如何传输您在未来7年提出的电子邮件代码？先谢谢你，感谢你的帮助。

Sub Send_Range() 
    Dim row As Long 
    Dim col As Long 
    Dim rCell As Range 
    Dim SendTo As String 
    Dim i As Long 

    row = Sheets("Email List").UsedRange.Rows.Count 
    col = Sheets("Email List").UsedRange.Columns.Count 

    If Not IsEmpty(Range("B4")) Then 
     With Sheets("Email List") 
      For Each rCell In .Range(.Cells(1, 1), .Cells(1, col)) 
       If rCell.Value <> "" Then 
        For i = 3 To row 
         If .Cells(i, rCell.Column).Value <> "" Then 
          SendTo = SendTo & .Cells(i, rCell.Column + 1).Value & ";" 
         End If 
        Next 
       End If 
      Next 
     End With 
    End If 

    If IsEmpty(Range("B4")) Then 
    Else 
     ActiveSheet.Range("a3", ActiveSheet.Range("e3").End(xlDown)).Select 
     ActiveWorkbook.EnvelopeVisible = True 
    With ActiveSheet.MailEnvelope 

     .Item.To = SendTo 
     .Item.Subject = "Allocations - Barclays" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 

     row = Sheets("Email List").UsedRange.Rows.Count 
    col = Sheets("Email List").UsedRange.Columns.Count 

    If Not IsEmpty(Range("B4")) Then 
     With Sheets("Email List") 
      For Each rCell In .Range(.Cells(1, 1), .Cells(1, col)) 
       If rCell.Value <> "" Then 
        For i = 3 To row 
         If .Cells(i, rCell.Column).Value <> "" Then 
          SendTo = SendTo & .Cells(i, rCell.Column + 1).Value & ";" 
         End If 
        Next 
       End If 
      Next 
     End With 
    End If 

    If IsEmpty(Range("H4")) Then 
    Else 
     ActiveSheet.Range("G3", ActiveSheet.Range("K3").End(xlDown)).Select 

    ActiveWorkbook.EnvelopeVisible = True 
     With ActiveSheet.MailEnvelope 
     .Item.To = "[email protected]" & "; [email protected]" 
     .Item.Subject = "Allocations - BNP" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 

     If IsEmpty(Range("N4")) Then 
    Else 
     ActiveSheet.Range("M3", ActiveSheet.Range("Q3").End(xlDown)).Select 

    ActiveWorkbook.EnvelopeVisible = True 
     With ActiveSheet.MailEnvelope 
     .Item.To = "[email protected]" & "; [email protected]" 
     .Item.Subject = "Allocations - CITINY" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 

    If IsEmpty(Range("T4")) Then 
    Else 
     ActiveSheet.Range("S3", ActiveSheet.Range("W3").End(xlDown)).Select 

    ActiveWorkbook.EnvelopeVisible = True 
     With ActiveSheet.MailEnvelope 
     .Item.To = "[email protected]" & "; [email protected]" 
     .Item.Subject = "Allocations - CSFB" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 

     If IsEmpty(Range("Z4")) Then 
    Else 
     ActiveSheet.Range("Y3", ActiveSheet.Range("AC3").End(xlDown)).Select 

    ActiveWorkbook.EnvelopeVisible = True 
     With ActiveSheet.MailEnvelope 
     .Item.To = "[email protected]" & "; [email protected]" 
     .Item.Subject = "Allocations - DB" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 

     If IsEmpty(Range("AF4")) Then 
    Else 
     ActiveSheet.Range("AE3", ActiveSheet.Range("AI3").End(xlDown)).Select 

    ActiveWorkbook.EnvelopeVisible = True 
     With ActiveSheet.MailEnvelope 
     .Item.To = "[email protected]" & "; [email protected]" 
     .Item.Subject = "Allocations - JPM" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 

     If IsEmpty(Range("AL4")) Then 
    Else 
     ActiveSheet.Range("AK3", ActiveSheet.Range("AO3").End(xlDown)).Select 

    ActiveWorkbook.EnvelopeVisible = True 
     With ActiveSheet.MailEnvelope 
     .Item.To = "[email protected]" & "; [email protected]" 
     .Item.Subject = "Allocations - MS" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 

     If IsEmpty(Range("AR4")) Then 
    Else 
     ActiveSheet.Range("AQ3", ActiveSheet.Range("AU3").End(xlDown)).Select 

    ActiveWorkbook.EnvelopeVisible = True 
     With ActiveSheet.MailEnvelope 
     .Item.To = "[email protected]" & "; [email protected]" 
     .Item.Subject = "Allocations - " & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
    End If 
End Sub

来源

2013-06-18 Anil Lulla

可以通过用分号分隔地址来发送多个电子邮件。

Email "[email protected];[email protected]", Subject:=:Example Email", Body:="Example Mail"

您可以搜索包含板材电子邮件的集电子邮件，你需要发邮件给每个电子邮件地址添加到字符串与每个人之间的分号。

Sub Example() 
    Dim rCell As Range 
    Dim SendTo As String 
    Dim i As Long 

    For Each rCell In Range(Cells(1, 1), Cells(1, ActiveSheet.UsedRange.Columns.Count)) 
     If rCell.Value = "DNP" Then 
      For i = 3 To ActiveSheet.UsedRange.Rows.Count 
       If Cells(i, rCell.Column).Value <> "" Then 
        SendTo = SendTo & Cells(i, rCell.Column + 1).Value & ";" 
       End If 
      Next 
      Exit For 
     End If 
    Next 

    Email SendTo 
End Sub

您可以通过以下发送电子邮件：

'--------------------------------------------------------------------------------------- 
' Desc : Sends an email 
' Ex : Email SendTo:[email protected], Subject:="example email", Body:="Email Body" 
'--------------------------------------------------------------------------------------- 
Sub Email(SendTo As String, Optional CC As String, Optional BCC As String, Optional Subject As String, Optional Body As String, Optional Attachment As Variant) 
    Dim s As Variant    'Attachment string if array is passed 
    Dim Mail_Object As Variant 'Outlook application object 
    Dim Mail_Single As Variant 'Email object 

    Set Mail_Object = CreateObject("Outlook.Application") 
    Set Mail_Single = Mail_Object.CreateItem(0) 

    With Mail_Single 
     'Add attachments 
     Select Case TypeName(Attachment) 
      Case "Variant()" 
       For Each s In Attachment 
        If s <> Empty Then 
         If FileExists(s) = True Then 
          Mail_Single.attachments.Add s 
         End If 
        End If 
       Next 
      Case "String" 
       If Attachment <> Empty Then 
        If FileExists(Attachment) = True Then 
         Mail_Single.attachments.Add Attachment 
        End If 
       End If 
     End Select 

     'Setup email 
     .Subject = Subject 
     .To = SendTo 
     .CC = CC 
     .BCC = BCC 
     .HTMLbody = Body 
     On Error GoTo SEND_FAILED 
     .Send 
     On Error GoTo 0 
    End With 

    Exit Sub 

SEND_FAILED: 
    With Mail_Single 
     MsgBox "Mail to '" & .To & "' could not be sent." 
     .Delete 
    End With 
    Resume Next 
End Sub 

Function FileExists(ByVal Path As String) As Boolean 
    'Remove trailing backslash 
    If InStr(Len(Path), Path, "\") > 0 Then Path = Left(Path, Len(Path) - 1) 
    'Check to see if the directory exists and return true/false 
    If Dir(Path, vbDirectory) <> "" Then FileExists = True 
End Function

CNC中这将让所有的电子邮件

Sub Send_Range() 
    Dim row As Long 
    Dim col As Long 
    Dim rCell As Range 
    Dim SendTo As String 
    Dim i As Long 

    row = Sheets("Email List").UsedRange.Rows.Count 
    col = Sheets("Email List").UsedRange.Columns.Count 

    If Not IsEmpty(Range("B4")) Then 
     With Sheets("Email List") 
      For Each rCell In .Range(.Cells(1, 1), .Cells(1, col)) 
       If rCell.Value <> "" Then 
        For i = 3 To row 
         If .Cells(i, rCell.Column).Value <> "" Then 
          SendTo = SendTo & .Cells(i, rCell.Column + 1).Value & ";" 
         End If 
        Next 
       End If 
      Next 
     End With 
    End If 

    ActiveWorkbook.EnvelopeVisible = True 

    With ActiveSheet.MailEnvelope 
     SendTo = Left(SendTo, Len(SendTo) - 1) 
     .Item.To = SendTo 
     .Item.Subject = "Allocations - Barclays" & Format(Date, " mm/dd/yyyy") 
     .Item.Send 
    End With 
End Sub

来源

2013-06-18 15:41:52 Ripster

谢谢你的。我目前有一个99％的代码，但只是缺少每个列表的第一封电子邮件。请告诉你是否可以。 –

'Sub Example'应该可以获得每封电子邮件。我制作了一张Excel表格来镜像您发布的图片并对其进行测试。 – Ripster

嗨Ripster，我很感激帮助。但是我已经得到了很多东西，并且认为我刚更新了原始文章的代码只需要一点点调整。请让我知道你是否可以帮忙。 –

使用VBA发送电子邮件到Excel上的电子邮件列表

回答

相关问题