給一個範圍（行）中的每個人發郵件

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 = YES/NO和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 
     ' ...