Envoyez un message à chaque personne dans une rangée (rangée)

Question

Je voudrais demander de l'aide pour changer le code de Ron de Bruins d'une colonne à l'autre (par exemple, la ligne 1 contient le nom, la ligne 2, la ligne 3 reflète Oui ou non).

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 

Merci beaucoup d'avance!

Answer 1

Peut-être comme ça ...

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 

Le code ci-dessus suppose que dire B1 = blanc, B2 = Nom, B3 = Adresse e-mail, B4 = Oui/Non et B5 = Blank. Vous pouvez avoir plusieurs ensemble d'enregistrements dans le même ordre dans la colonne B.

Answer 2

Si vous voulez dire que les noms et les courriels sont en lignes 1 et 2, une personne par colonne, cette modification devrait faire:

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 
     ' ...