如何在Excel VBA中实现按H列条件触发邮件发送？

我们需要修改现有的sendCustEmails宏，让它仅当MS_Data工作表对应行的H列存在有效值（例如"y"）时，才执行邮件发送操作。以下是修改后的完整代码：

Option Explicit

Sub sendCustEmails()
    Dim objOutlook As Object
    Dim objEmail As Object
    Dim strMailBody As String, StrMailSubject As String
    Dim intRow As Integer
    Dim strISO As String, strSalutation As String, strEmail As String
    Dim strCC As String, strFile As String, strFile2 As String, strFolder As String
    Dim strSendFlag As String ' 存储H列的发送标记
    
    Set objOutlook = CreateObject("Outlook.Application")
    
    intRow = 2
    strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
    
    While strISO <> ""
        ' 读取当前行H列的标记值
        strSendFlag = Trim(ThisWorkbook.Sheets("MS_Data").Range("H" & intRow).Text)
        
        ' 仅当H列存在有效值时发送邮件，若需限定为"y"可改为If UCase(strSendFlag) = "Y"
        If strSendFlag <> "" Then
            Set objEmail = objOutlook.CreateItem(0) ' oMailItem对应常量值0，避免未定义错误
            
            StrMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
            strMailBody = "<BODY style='font-size:11pt;font-family:Calibri(Body)'>" & ThisWorkbook.Sheets("Mail_Details").Range("B2").Text & "</BODY>"
            strMailBody = Replace(strMailBody, Chr(10), "<br>")
            
            strFolder = "C:\Users\CIOTTIC\OneDrive - IAEA\Desktop\AL TEST"
            strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
            strSalutation = ThisWorkbook.Sheets("MS_Data").Range("C" & intRow).Text
            strEmail = ThisWorkbook.Sheets("MS_Data").Range("D" & intRow).Text
            strCC = ThisWorkbook.Sheets("MS_Data").Range("E" & intRow).Text
            strFile = ThisWorkbook.Sheets("MS_Data").Range("F" & intRow).Text
            strFile2 = ThisWorkbook.Sheets("MS_Data").Range("G" & intRow).Text
            
            StrMailSubject = Replace(StrMailSubject, "<ISO>", strISO)
            strMailBody = Replace(strMailBody, "<Salutation>", strSalutation)
            
            With objEmail
                .To = CStr(strEmail)
                .CC = CStr(strCC)
                .Subject = StrMailSubject
                .BodyFormat = 2 ' olFormatHTML对应常量值2
                .Display
                ' 仅当附件路径有效时添加，避免报错
                If strFile <> "" Then .Attachments.Add strFolder & "\" & strFile
                If strFile2 <> "" Then .Attachments.Add strFolder & "\" & strFile2
                .HTMLBody = strMailBody & .HTMLBody
                .Send
            End With
            
            Set objEmail = Nothing ' 释放对象
        End If
        
        intRow = intRow + 1
        strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
    Wend
    
    Set objOutlook = Nothing
    MsgBox "Done"
End Sub

关键修改说明： #

• 添加Option Explicit强制变量声明，避免因拼写错误导致的隐式变量问题
• 新增strSendFlag变量读取H列内容，通过条件判断控制邮件发送逻辑
• 将邮件创建、内容填充、发送的核心逻辑包裹在条件块内，不满足条件时跳过当前行
• 替换原代码中未定义的常量为对应数值，避免未引用Outlook库导致的编译错误
• 增加附件存在性判断，避免空路径引发的运行时错误
• 添加对象释放语句，优化内存占用

内容的提问来源于stack exchange，提问作者Cynthia