Excel VBA批量发邮件代码：将遍历所有单元格改为指定范围的语法求助

我明白你现在的问题啦——原来的宏会给B列所有带常量的收件人发7封邮件，但你只想给指定数量（比如前5个）符合条件的收件人发送，之前尝试用For Each i =1 to 5的写法报错了对吧？这是因为For Each和For...To是两种完全不同的循环语法，不能混在一起使用～

下面给你两种简单可行的修改方案，都能实现只遍历指定数量的收件人：

方案一：用计数器限制循环次数 #

直接在原循环中加入计数器，每处理一个收件人就递增计数，达到指定数量后立即退出循环。修改后的完整代码如下：

Sub Sengrd_Files()
 Dim OutApp As Object
 Dim OutMail As Object
 Dim sh As Worksheet
 Dim cell As Range
 Dim FileCell As Range
 Dim rng As Range
 Dim counter As Integer ' 新增计数器变量
 para2 = ""
 para3 = ""
 para232 = Range("AA2").Value
 With Application
 .EnableEvents = False
 .ScreenUpdating = True
 End With
 Set sh = Sheets("Sheet1")
 Set OutApp = CreateObject("Outlook.Application")

 counter = 0 ' 初始化计数器
 For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
 counter = counter + 1
 ' 当处理数量超过5时，退出循环（可修改数字调整数量）
 If counter > 5 Then Exit For

 '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 = "Circle Profitability Report for the period ended 30-NOV-2017"
 .Body = "Dear Sir/Madam," _
 & vbNewLine _
 & para232 & vbNewLine _
 & vbNewLine & para2 & vbNewLine _
 & Remark & vbNewLine & vbNewLine _
 & para3 & vbNewLine & vbNewLine
 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

关键修改点：

• 新增counter变量作为计数器，初始值设为0
• 每次循环时计数器加1，当counter > 5时执行Exit For退出循环，停止处理后续收件人

方案二：先捕获所有符合条件的单元格，再遍历指定数量 #

如果需要更灵活地控制收件人范围，可以先把所有符合条件的单元格存储到一个变量中，再只遍历前N个元素：

Sub Sengrd_Files()
 Dim OutApp As Object
 Dim OutMail As Object
 Dim sh As Worksheet
 Dim cell As Range
 Dim FileCell As Range
 Dim rng As Range
 Dim recipientCells As Range ' 存储所有符合条件的收件人单元格
 Dim counter As Integer ' 计数器
 para2 = ""
 para3 = ""
 para232 = Range("AA2").Value
 With Application
 .EnableEvents = False
 .ScreenUpdating = True
 End With
 Set sh = Sheets("Sheet1")
 Set OutApp = CreateObject("Outlook.Application")

 ' 捕获B列所有带常量的单元格（防止无符合条件单元格报错）
 On Error Resume Next
 Set recipientCells = sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
 On Error GoTo 0

 ' 仅当存在符合条件的单元格时才执行循环
 If Not recipientCells Is Nothing Then
 counter = 0
 For Each cell In recipientCells
 counter = counter + 1
 If counter > 5 Then Exit For ' 限制只处理前5个

 '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 = "Circle Profitability Report for the period ended 30-NOV-2017"
 .Body = "Dear Sir/Madam," _
 & vbNewLine _
 & para232 & vbNewLine _
 & vbNewLine & para2 & vbNewLine _
 & Remark & vbNewLine & vbNewLine _
 & para3 & vbNewLine & vbNewLine
 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
 End If

 Set OutApp = Nothing
 With Application
 .EnableEvents = True
 .ScreenUpdating = True
 End With
End Sub

关键修改点：

• 新增recipientCells变量存储所有符合条件的单元格
• 加入错误处理，避免没有符合条件单元格时程序报错
• 同样用计数器控制只遍历前5个单元格

注意事项 #

• 如果你想修改处理的收件人数量，只需要把代码中的5改成你需要的数字即可
• 如果你的B列中存在不符合邮箱格式的单元格，代码里的cell.Value Like "?*@?*.?*"判断会自动跳过这些收件人

内容的提问来源于stack exchange，提问作者Rahul Shah