在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