使用Excel VBA

Question

正在开展一个项目，如果满足条件，将向不同的人发送大量邮件。

条件：

1. 列U包含最终状态（开放或在制品）（如果当前日期较大，则无法在关闭时发送）
2. 列Q包含关闭日期。与当前日期相比，如果少于自动拍摄邮件给人们。

我曾尝试使用for循环，但是它使用相同的To和CC拍摄4封邮件。而不是去下一行进行比较。

提前谢谢。

代码如下：

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim x As Variant
Dim arr1 As Variant

Dim i As Long, r As Long

On Error Resume Next
arr1 = Worksheets("Data").Range("Q2:Q" & Range("Q" & Rows.Count).End(xlUp).row).Value
i = 1
For Each x In arr1
    For r = 1 To 2

        If x < Now() Then


        If Sheets("Data").Worksheets("Data").Cells(i, "U").Value = "Open" Then   


            Set rng = Nothing
            On Error Resume Next
            'Only the visible cells in the selection
            Set rng = Selection.SpecialCells(xlCellTypeVisible)
            'You can also use a fixed range if you want
            Set rng = Sheets("Checklist").Range("A2:B25").SpecialCells(xlCellTypeVisible)
            On Error GoTo 0


            With Application
            .EnableEvents = False
            .ScreenUpdating = False
            End With

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

    With OutMail


            If Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Quality_Assurance" Then


     StrBody = "Hi," & "<br>" & _


    .To = "a"

    .CC = "b"
    .BCC = ""
    .Subject = ""
    .HTMLBody = StrBody & RangetoHTML(rng)
    .Attachments.Add ActiveWorkbook.FullName
    ' You can add other files by uncommenting the following line.
    '.Attachments.Add ("C:\test.txt")
    .Display
    '.Send

    ElseIf Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Analytics" Then

StrBody = "Hi," & "<br>" & _
          "PFB the process details which requires your attention." & "<br>" & _
          "The review for this process has crossed over due." & "<br>" & _
          "Please ask the process owner to review the Process Manuals and Maps." & "<br><br><br>"

    .To = "c"

    .CC = "d"
    .BCC = ""
    .Subject = "Process Manual and Maps Review is Overdue"
    .HTMLBody = StrBody & RangetoHTML(rng)
    .Attachments.Add ActiveWorkbook.FullName
    ' You can add other files by uncommenting the following line.
    '.Attachments.Add ("C:\test.txt")
    .Display
    '.Send
End If

    End With

    i = i + 1
    Exit For

    End If
End If

Next r

On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

Next x
End Sub

Answer 1

解决：这将解决上述问题。

Sub Data_RoundedRectangle1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range

For i = 2 To Cells(Rows.Count, 1).End(xlUp).row

If Cells(i, 21).Value = "Open" And Cells(i, 17).Value <= Now() Then

Set rng = Nothing
            On Error Resume Next
            'Only the visible cells in the selection
            Set rng = Selection.SpecialCells(xlCellTypeVisible)
            'You can also use a fixed range if you want
            Set rng = Sheets("Data").Range("C1:V5").SpecialCells(xlCellTypeVisible)
            On Error GoTo 0


            With Application
            .EnableEvents = False
            .ScreenUpdating = False
            End With



Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail


    If Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).Value = "Quality_Assurance" Then


        StrBody = "Hi," & "<br>" & _
          "PFB the process details which requires your attention." & "<br>" & _
          "The review for this process has crossed overdue." & "<br>" & _
          "Please ask the process owner to review the Process Manuals and Maps." & "<br><br><br>"

    .To = "a"
    .CC = "b"
    .BCC = ""
    .Subject = ""
    .HTMLBody = StrBody & RangetoHTML(rng)
    .Attachments.Add ActiveWorkbook.FullName
    ' You can add other files by uncommenting the following line.
    '.Attachments.Add ("C:\test.txt")
    .Display
    '.Send

    ElseIf Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).Value = "Analytics" Then

StrBody = "Hi," & "<br>" & _
          "PFB the process details which requires your attention." & "<br>" & _
          "The review for this process has crossed over due." & "<br>" & _
          "Please ask the process owner to review the Process Manuals and Maps." & "<br><br><br>"

    .To = "c"
    .CC = "s"
    .BCC = ""
    .Subject = ""
    .HTMLBody = StrBody & RangetoHTML(rng)
    .Attachments.Add ActiveWorkbook.FullName
    ' You can add other files by uncommenting the following line.
    '.Attachments.Add ("C:\test.txt")
    .Display
    '.Send

End If
End With


On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End If
Next i

End Sub