如何修改Excel VBA批量发邮件代码以抄送指定列（H列）的对应邮箱

针对需求（从H列提取同一行的邮箱地址作为邮件抄送），修改后的完整VBA代码如下：

Sub Send_Bulk_Mails()
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Recipient Input")
    Dim i As Integer

    Dim OA As Object
    Dim msg As Object

    Set OA = CreateObject("outlook.application")

    PathFileName = "G:\WIN\..."

    Dim last_row As Integer
    last_row = Application.CountA(sh.Range("A:A"))

    For i = 2 To last_row
        If sh.Range("G" & i).Value <> "Sent" Then

            Set msg = OA.CreateItemFromTemplate(PathFileName)
            
            msg.To = sh.Range("E" & i).Value
            ' 新增：从H列提取对应行的邮箱作为抄送
            If Trim(sh.Range("H" & i).Value) <> "" Then
                msg.CC = sh.Range("H" & i).Value
            End If
            
            msg.Subject = "We need your support"
            

            With msg
                .SentOnBehalfOfName = "cap..@yahoo.com"
                .HTMLBody = Replace(.HTMLBody, "....", sh.Range("C" & i).Value & " " & sh.Range("B" & i).Value)
                .HTMLBody = Replace(.HTMLBody, "....", sh.Range("D" & i).Value)
                .Display
                Application.Wait (Now + TimeValue("0:00:02"))
                Application.SendKeys "%s"
                
            End With
            
            sh.Range("G" & i).Value = "Sent"
            
        End If

    Next i

    MsgBox "All emails have been sent"

End Sub

关键修改说明 #

• 在设置收件人msg.To之后，新增了H列邮箱的读取逻辑：
  • 用Trim(sh.Range("H" & i).Value) <> ""判断当前行H列是否有有效内容，避免添加空抄送地址
  • 通过msg.CC = sh.Range("H" & i).Value将对应行的H列邮箱设置为邮件抄送
• 如果同一行需要添加多个抄送地址，可在H列用分号;分隔多个邮箱（符合Outlook的地址格式要求）

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