Question

我为我的电子表格创建了一个宏，可以成功发送电子邮件。

但是，它只能发送超过截止日期的每个单独部件号的电子邮件。这意味着，如果我的截止日期中有100个，则会发送100封电子邮件。

我希望我的宏通过一系列类似产品（例如打印机）的单元格发送电子邮件，并且在截止日期之前。还可以有其他产品，如笔记本电脑，相机，网络摄像头。我需要这样做，因为我不想垃圾邮件收件人的收件箱。

我该怎么做？

Sub LabelArtworkRelease()

    Dim OutApp As Object
    Dim Message1 As Object
    Dim cell As Range
    Dim emailBody As String
    Dim Signature As String

    'GET DEFAULT EMAIL SIGNATURE
    Signature = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else:
        Signature = ""
    End If
    Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
    'End

    Application.ScreenUpdating = False

    'Create a new Outlook session
    Set appOutlook = CreateObject("Outlook.Application")

    On Error GoTo cleanup

            'Declare header variables
            partnumber = Range("A3").Value
            productfamily = Range("B3").Value
            desc = Range("C3").Value
            artworkactual = Range("F3").Value
            artworkexpected = Range("G3").Value
            remark = Range("L3").Value

            On Error Resume Next

            'if artwork actual date is later than artwork expected date
            For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
            If Cells(cell.Row, "G").Value < Cells(cell.Row, "F").Value And Cells(cell.Row, "L").Value = "Incomplete" Then

            'Create a new message
            Set Message1 = appOutlook.CreateItem(olMailItem)


            'Create default message
            emailBody = "<Font face=Calibri>Hi " & Cells(cell.Row, "D").Value & " , <p>" _
                            & "Please be reminded that the following part numbers - is/are over the expected artwork release date. <p> Kindly act on the following item(s): <br> " _
                            & "<table border=1><tr><th>" _
                            & partnumber & "</th>" _
                            & "<th>" & productfamily & "</th>" _
                            & "<th>" & desc & "</th>" _
                            & "<th>" & artworkactual & "</th>" _
                            & "<th>" & artworkexpected & "</th>" _
                            & "<th>" & remark & "</th>" _
                            & "<tr>" _
                            & "<td>" & Cells(cell.Row, "A").Value & "</td>" _
                            & "<td>" & Cells(cell.Row, "B").Value & "</td>" _
                            & "<td>" & Cells(cell.Row, "C").Value & "</td>" _
                            & "<td>" & Cells(cell.Row, "F").Value & "</td>" _
                            & "<td>" & Cells(cell.Row, "G").Value & "</td>" _
                            & "<td>" & Cells(cell.Row, "L").Value & "</td></tr></table><br /></font>" & Signature



            With Message1
                .to = "email@email.com"
                .CC = Cells(cell.Row, "N") & ";" & Cells(cell.Row, "O")
                .Subject = "Reminder for Label Artwork Tracking (Artwork Expected Date) - Product Family (" & Cells(cell.Row, "B").Value & ")"
                .HTMLBody = emailBody



                .Send
                End With




            On Error GoTo 0
            Set OutMail = Nothing
    End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 1

首先，您可以使用产品名称按字母顺序对列进行排序，然后在if语句中添加如下条件：

If Cells(cell.Row, "Product name column").Value <> Cells(cell.Row + 1, "Product name column").Value then

因此宏只在到达具有相同名称的最后一项后才运行其余代码。

宏以循环显示具有相似价值/产品的单元格并发送该范围的电子邮件

1 个答案: