VBA 1000电子邮件地址-发送20个一组的电子邮件

Question

从a列的1000个电子邮件地址列表中，如何一次以20个地址为一组发送相同的电子邮件？

Sub SendEmail()
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As Range
Dim email_ As String
Dim cc_ As String
Dim subject_ As String
Dim body_ As String
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In Columns("a").Cells.SpecialCells(xlCellTypeConstants)
email_ = cell.Value
subject_ = cell.Offset(0, 1).Value
body_ = cell.Offset(0, 2).Value
cc_ = cell.Offset(0, 3).Value
'Create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0)
With MItem
.To = email_
.CC = cc_
.Subject = subject_
.Body = body_


.Display
End With
Next

结束子

Answer 1

类似这样的东西：

Sub SendEmail()
Const SEND_EVERY As Long = 20
Dim OutlookApp As Object
Dim cell As Range
Dim email_ As String
Dim cc_ As String, subject_ As String, body_ As String, i As Long, first As Boolean

Set OutlookApp = CreateObject("Outlook.Application")

i = 0
first = True
'Loop through the rows
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)

i = i + 1      '<< fixed here
If first Then
'the first cell in a batch: collect common info and first address
email_ = cell.Value
subject_ = cell.Offset(0, 1).Value
body_ = cell.Offset(0, 2).Value
cc_ = cell.Offset(0, 3).Value
first = False
Else
email_ = email_ & ";" & cell.Value 'just add the email
End If

If i Mod SEND_EVERY = 0 Then 'on the 20th cell or a multiple of that?
CreateMail OutlookApp, email_, cc_, subject_, body_ 'send accumulated
first = True                                    'reset flag
End If

Next cell

'send any remaining items
If i Mod SEND_EVERY > 0 Then
CreateMail OutlookApp, email_, cc_, subject_, body_
End If

End Sub
Sub CreateMail(oApp As Object, sTo, sCC, sSubject, sBody)
With oApp.CreateItem(0)
.To = sTo
.CC = sCC
.Subject = sSubject
.Body = sBody
.Display
End With
End Sub