在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