Проблемы с циклизацией по нескольким столбцам в Excel VBA

Question

Мой код VBA проходит через столбец «I» с именами людей и создает список писем. В теле письма есть список строк для каждого человека из столбцов B, C, G, I. Довольно просто, однако я сталкиваюсь с проблемой с последним. Это занимает только первую строку для каждого человека, т. Е. Не перебирает список, чтобы получить все строки для одного получателя. У меня есть ощущение, что это как-то останавливает его от зацикливания дальше:

  If InStr(1, PriorRecipients, EmailAddr) <> 0 Then 
      GoTo NextRecipient 
     End If 

, но не уверен, как реализовать второй цикл ??

Полный код:

Sub SendEmail2() 

    Dim OutlookApp 
    Dim MItem 
    Dim cell As Range 
    Dim Subj As String 
    Dim EmailAddr As String 
    Dim Recipient As String 
    Dim Msg As String 
    Dim Projects As String 
    Dim ProjectsMsg As String 
    Dim bSendMail As Boolean 


    'Create Outlook object 
    Set OutlookApp = CreateObject("Outlook.Application") 
    Set MItem = OutlookApp.CreateItem(0) 
    'Loop through the rows 
    For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible) 
    If cell.Value <> "" And _ 
      (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then 
      'first build email address 
      EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com" 
      'then check if it is in Recipient List build, if not, add it, otherwise ignore 
      If InStr(1, Recipient, EmailAddr) = 0 Then Recipient = Recipient & ";" & EmailAddr 

      Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value 
      If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf 

     If InStr(1, Recipient, cell.Offset(1).Value) <> 0 Then 
      bSendMail = True 
      Recipient = Recipient & ";" & cell.Offset(1) 
      Else 
      bSendMail = False 
     End If 

End If 
Next 
    Msg = "You have the following outstanding documents to be reviewed at: "& ProjectsMsg 
    Subj = "Outstanding Documents to be Reviewed" 
    'Create Mail Item and view before sending 
    If bSendMail Then Set MItem = OutlookApp.CreateItem(olMailItem) 
    With MItem 
     .To = Recipient 'full recipient list 
     .Subject = Subj 
     .Body = Msg 
     .display 

    End With 


End Sub 

Answer 1

Изменить этот блок кода:

If InStr(1, PriorRecipients, EmailAddr) <> 0 Then 
    GoTo NextRecipient 
    End If 

    PriorRecipients = PriorRecipients & ";" & EmailAddr 

Для этого

If InStr(1, PriorRecipients, EmailAddr) = 0 Then 
    PriorRecipients = PriorRecipients & ";" & EmailAddr 
End If 

'checks if it's the last email for that unique person and if so, 
`it's done looping rows for that email and the email is good to send 
If Instr(1, PriorRecipients, cell.Offset(1).Value) <> 0 Then 
    Dim bSendMail as Boolean 
    bSendMail = True 
    PriorRecipients = PriorRecipients & ";" & cell.Offset(1) 
Else 
    bSendMail = False 
End If 

If bSendMail Then 
    Set MItem = OutlookApp.CreateItem(olMailItem) 
    ' rest of code to send mail ... 
End If