Question

我想请求协助我如何从列到行更改Ron de Bruins代码（例如，第1行包含名称;第2行电子邮件;第3行反映是或否）。

Sub Test1()
'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 = cell.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

提前非常感谢你！

Answer 1

也许这样......

Sub Test1()
'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 Rng As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each Rng In Columns("B").Cells.SpecialCells(xlCellTypeConstants).Areas
    If Rng.cell(2).Value Like "?*@?*.?*" And _
       LCase(Rng.Cells(3).Value) = "yes" Then

        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = Rng.cell(2).Value
            .Subject = "Reminder"
            .Body = "Dear " & Rng.cell(1).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 Rng
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

上面的代码假设说B1 =空白，B2 =姓名，B3 =电子邮件地址，B4 =是/否，B5 =空白。您可以在B列中以相同的顺序拥有各种记录集。

Answer 2

如果你的意思是名称和电子邮件在第1行和第2行，每列一个人，那么这个修改应该这样做：

For Each cell In Rows(2).Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And LCase(cell.offset(1).Value) = "yes" Then
        ' ....
        .To = cell.Value
        .Body = "Dear " & cell.offset(-1).Value
        ' ...

将邮件发送给范围内的每个人（行）

2 个答案: