我发现了用于向列中的每个人发送电子邮件的宏。
B列显示在C列中具有“是”的名称。我已在Power Query中添加了此条件。
Sub Send_Row_Or_Rows_Attachment_1()
'Working in 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Dim intHowManyRows As Integer
With Application
.ScreenUpdating = False
End With
intHowManyRows = Application.Range("B2").CurrentRegion.Rows.Count
For r = 1 To intHowManyRows
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ThisWorkbook.Sheets("Sheet3").Range("B1").Value
' Cells(r, 2).Value
.Subject = Cells(r, 3).Value
'.Attachments.Add FullName -> If you want to add attachments
.Body = "Hi there" & vbNewLine & vbNewLine & "How are you " & Cells(r, 2)
.Display 'Or use Send
End With
Next r
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
或:
Sub Test2()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ThisWorkbook.Sheets("Sheet3").Range("B1").Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
我想与“收件人”中B列中的所有人员生成一个Outlook邮件,并附加一个文件。
我调整了罗恩的代码。查看我的评论并对其进行调整以满足您的需求。
编辑:根据niton的建议,接下来删除on错误履历表,并查看导致错误的行。
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table1").ListObject ' -> Set the table's name
On Error GoTo cleanup
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
.Attachments.Add ("C:\test.txt") ' -> Adjust this path
.Send ' -> Or use Display
End With
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
让我知道它是否有效。