VBA跨工作表检测小于1数值后汇总发送单封通知邮件的实现问题

你原来的代码问题在于边检测边触发邮件发送，没有先汇总所有异常内容。调整逻辑为「先全量遍历收集所有异常→汇总后统一发送1次邮件」即可，同时优化了重复代码和原代码里的变量未赋值bug，完整可运行代码如下：

Option Explicit

Sub Main()
    Dim sh As Worksheet
    Dim mailBody As String
    Dim hasException As Boolean
    
    ' 初始化汇总内容
    mailBody = "Hi there bud，以下工作表需要调整：" & vbNewLine & vbNewLine
    hasException = False
    
    ' 遍历所有工作表，仅收集异常，不发邮件
    For Each sh In ActiveWorkbook.Worksheets
        With WorksheetFunction
            ' 检查L列异常
            If .CountIf(sh.Range("L3:L26"), "<1") > 0 Then
                mailBody = mailBody & "- 工作表【" & sh.Name & "】：需调整Rotations" & vbNewLine
                hasException = True
            Else
                MsgBox "Rotations NOT needed for """ & sh.Name & """."
            End If
            
            ' 检查M列异常
            If .CountIf(sh.Range("M3:M20"), "<1") > 0 Then
                mailBody = mailBody & "- 工作表【" & sh.Name & "】：需调整Functions" & vbNewLine
                hasException = True
            Else
                MsgBox "Functions are NOT needed for """ & sh.Name & """."
            End If
        End With
    Next
    
    ' 所有表遍历完成后，判断是否需要发邮件
    If hasException Then
        Call SendReminderMail("工作表调整提醒", mailBody)
        MsgBox "汇总邮件已触发，运行时间：" & TimeValue(Now), vbInformation
    Else
        MsgBox "所有工作表均无异常，无需发送邮件", vbInformation
    End If
End Sub

' 通用发邮件子程序，接收主题和正文参数
Sub SendReminderMail(mailSubject As String, mailContent As String)
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object

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

    Set wb1 = ActiveWorkbook

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

    wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
    wb2.Save

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

    On Error Resume Next
    With OutMail
        .To = "test@test.com"
        .CC = ""
        .BCC = ""
        .Subject = mailSubject
        .Body = mailContent
        .Attachments.Add wb2.FullName
        .Display   '需要自动发送改为.Send即可
    End With
    On Error GoTo 0
    
    wb2.Close savechanges:=False
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

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

核心修改点 #

• 新增异常内容收集逻辑：遍历过程中只把符合条件的工作表和对应调整类型写入汇总字符串，不触发邮件发送
• 合并重复的发邮件代码为通用方法，支持传入自定义主题和正文，减少冗余
• 修复原代码中发邮件子程序内sh变量未赋值的问题，避免主题内容为空
• 全量遍历完成后仅触发一次邮件发送，无异常时不会生成邮件

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