Vba 在4列中发送包含电子邮件地址的邮件

我用Ron de Bruin的脚本发送电子邮件，其中有从B列值发送电子邮件地址的选项

我至少有4列从B列到E列的电子邮件地址。如何修改此栏以发送此电子邮件

例如：

在表格（“表格1”）中列出以下内容：

• A栏：人员姓名
• 在B列中：电子邮件地址
• 在C:Z列中：文件名如下：

  C:\Data\Book2.xls

  （不必是Excel文件）

宏将在

Sheet1

中的每一行循环，如果B列中有电子邮件地址，C:Z列中有文件名，它将创建一封包含此信息的邮件并发送

Sub Send_Files()
'Working in Excel 2000-2013
'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

子发送_文件（）
“使用Excel 2000-2013
“有关提示，请参阅：http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp作为对象
将邮件变暗为对象
将sh设置为工作表
暗淡单元格作为范围
将文件单元设置为范围
变暗rng As范围
应用
.EnableEvents=False
.ScreenUpdate=False
以
设置sh=图纸（“图纸1”）
Set-OutApp=CreateObject（“Outlook.Application”）
对于sh.Columns（“B”）.Cells.SpecialCells（xlCellTypeConstants）中的每个单元格
'在每行的C:Z列中输入路径/文件名
设置rng=sh.Cells（cell.Row，1）.范围（“C1:Z1”）
如果单元格值像“*@*。？*”和_
Application.WorksheetFunction.CountA（rng）>0则
Set-OutMail=OutApp.CreateItem（0）
发邮件
.to=单元格.Value
.Subject=“Testfile”
.Body=“Hi”&单元格偏移量（0，-1）.Value
对于rng.SpecialCells中的每个文件单元（xlCellTypeConstants）
如果修剪（文件单元）”，则
如果Dir（FileCell.Value）“，则
.Attachments.Add FileCell.Value
如果结束
如果结束
下一个文件单元
.Send'或use.Display
以
发送邮件=无
如果结束
下一个细胞
设置应用程序=无
应用
.EnableEvents=True
.ScreenUpdate=True
以
端接头

大量编辑

根据您的评论，下面的代码已更改。应在假定列

F

中有文件名的情况下工作。要删除/注释掉的行在下面的代码中标记，以防您不需要此要求

Private Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'--BK201 mod: http://stackoverflow.com/questions/20776481/send-mail-with-email-address-in-4-columns--'

Dim OutApp As Object
Dim OutMail As Object
Dim Sh As Worksheet
Dim FileCell As Range
Dim Rec As Range, RecRng As Range, RecList As Range, RecMail As Range
Dim FileRng As Range
Dim RecStr As String

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set Sh = ThisWorkbook.Sheets("Sheet1")
Set RecList = Sh.Range("B:B")
Set OutApp = CreateObject("Outlook.Application")

For Each Rec In RecList

    With Sh
        Set RecRng = .Range("B" & Rec.Row & ":E" & Rec.Row)
        Set FileRng = .Range("F" & Rec.Row)
    End With

    RecStr = ""
    For Each RecMail In RecRng
        If RecMail.Value Like "?*@?*.?*" Then
            RecStr = RecStr & RecMail.Value & ";"
        End If
    Next RecMail

    If Len(FileRng.Value) > 0 Then '--Comment out if alright to send without attachment.
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = RecStr
            .Subject = "Testfile"
            .Body = "Hi " & Rec.Offset(0, -1).Value

            On Error Resume Next
            For Each FileCell In FileRng
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            .Display '.Send
        End With
        Set OutMail = Nothing
    Else '--Comment out if alright to send without attachment.
        Exit For '--Comment out if alright to send without attachment.
    End If '--Comment out if alright to send without attachment.

Next Rec

Set OutApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Private Sub发送_文件（）
“使用Excel 2000-2013
“有关提示，请参阅：http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
--BK201 mod：http://stackoverflow.com/questions/20776481/send-mail-with-email-address-in-4-columns--'
Dim OutApp作为对象
将邮件变暗为对象
将Sh设置为工作表
将文件单元设置为范围
Dim Rec As Range、RecRng As Range、RecList As Range、RecMail As Range
Dim FileRng As范围
作为字符串的Dim RecStr
应用
.EnableEvents=False
.ScreenUpdate=False
以
Set Sh=ThisWorkbook.Sheets（“Sheet1”）
设置重新列表=Sh.Range（“B:B”）
Set-OutApp=CreateObject（“Outlook.Application”）
对于RecList中的每个Rec
与Sh
Set RecRng=.Range（“B”和记录行&“：E”和记录行）
设置FileRng=.Range（“F”和Rec.Row）
以
RecStr=“”
对于重新创建中的每个RecMail
如果RecMail.Value像“*@*。？*”那么
RecStr=RecStr&RecMail.Value&“；”
如果结束
下一封邮件
如果Len（FileRng.Value）>0，则'--如果可以发送而不附加附件，则注释掉。
Set-OutMail=OutApp.CreateItem（0）
发邮件
.to=RecStr
.Subject=“Testfile”
.Body=“Hi”&记录偏移量（0，-1）.Value
出错时继续下一步
对于FileRng中的每个FileCell
如果修剪（文件单元）”，则
如果Dir（FileCell.Value）“，则
.Attachments.Add FileCell.Value
如果结束
如果结束
下一个文件单元
.Display'.Send
以
发送邮件=无
Else'--如果可以发送而不附加附件，则注释掉。
退出'——如果可以发送而不附加附件，则注释掉。
结束如果'——如果可以发送而不附加附件，则注释掉。
下一个记录
设置应用程序=无
应用
.EnableEvents=True
.ScreenUpdate=True
以
端接头

设置：

结果：

---

希望这有帮助。：）

标题有点误导，第二行的信息也不匹配。你说你有来自

B:e

的电子邮件地址，但你也有来自

C:Z

的文件名。假设您在

B

中只有电子邮件地址，并且您要附加的文件在

C:Z

中，这样安全吗？对不起，我粘贴了，没有修改脚本，事实上电子邮件地址在B:e栏，附件在F栏。感谢您的澄清。因此，它的工作方式是，如果

F

有一个附件，并且所有

B:E

都有收件人，那么要发送给所有这些收件人吗？请根据您的规格进行更改。请参见下面编辑的代码。