Excel VBA技术求助：如何在Outlook邮件正文引入色码右侧单元格区域数据

需求说明 #

工作表中通过单元格颜色（对应ColorIndex：灰色=15，黄色=19等）对产品分组，需将符合颜色条件的单元格右侧第1、2、3位单元格的内容提取出来，插入Outlook邮件正文，无需保留格式。

修正后的VBA代码 #

'===========================
'EMAIL PLACE MATERIAL ORDER'
'===========================

Dim Cell As Range
Dim ws As Worksheet
Dim eApp As Outlook.Application
Dim eItem As Outlook.MailItem
Dim mailBody As String
Dim targetColorIndices As Variant
Dim colorCell As Range

' 指定目标工作表，替换为你的工作表名称
Set ws = ThisWorkbook.Worksheets("Sheet1")
' 设置需要筛选的ColorIndex值，可按需添加更多
targetColorIndices = Array(15, 19)

' 初始化Outlook对象
Set eApp = New Outlook.Application
Set eItem = eApp.CreateItem(olMailItem)

' 设置邮件基础信息
eItem.To = "email@email.com"
eItem.Subject = ws.Range("D21").Value

' 构建邮件正文开头
mailBody = "Automated Email - advise sender of errors." & vbNewLine & vbNewLine & _
           "Please order the following:" & vbNewLine & vbNewLine

' 遍历指定区域的单元格（示例为B2:F100，可根据实际范围调整）
For Each colorCell In ws.Range("B2:F100")
    ' 判断当前单元格颜色是否属于目标分组
    If IsInArray(colorCell.Interior.ColorIndex, targetColorIndices) Then
        ' 提取右侧第1-3位单元格内容，用制表符分隔列
        mailBody = mailBody & colorCell.Offset(0, 1).Value & vbTab & _
                   colorCell.Offset(0, 2).Value & vbTab & _
                   colorCell.Offset(0, 3).Value & vbNewLine
    End If
Next colorCell

' 将拼接好的正文赋值给邮件
eItem.Body = mailBody

' 显示邮件（如需直接发送，替换为eItem.Send）
eItem.Display

' 释放对象，避免内存泄漏
Set eItem = Nothing
Set eApp = Nothing

' 辅助函数：判断值是否在目标数组中
Function IsInArray(valToCheck As Variant, arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If valToCheck = element Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

关键修正点 #

• 明确工作表指向：指定ws为目标工作表，避免默认工作表导致的逻辑错误
• 颜色匹配逻辑：用数组存储目标ColorIndex，遍历单元格逐一校验，仅提取符合条件的内容
• 正文构建方式：通过字符串拼接生成邮件正文，用换行符和制表符保证内容排版清晰
• 修复原代码问题：修正etem.BCC的拼写错误，移除无效的Range直接赋值语句
• 内存优化：添加对象释放语句，避免Outlook对象占用内存

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