如何修改代码实现向多个收件人发送指定单元格区域内容

Hey there! No worries at all—we all start somewhere, and it’s awesome you’re digging into automating emails with VBA. Let’s tweak that code so it can handle multiple recipients and CCs from your spreadsheet.

First, let’s assume your spreadsheet has a structure like this (you can adjust the ranges to match your setup):

• Column A: List of To recipients (one per row)
• Column B: List of CC recipients (one per row)
• Columns C-E: The cell range you want to include in each email

Here’s the modified code that pulls multiple recipients/CCs and sends the email with your specified range content:

Sub SendEmailsWithMultipleRecipients()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim toRng As Range, ccRng As Range, bodyRng As Range
    Dim toRecipients As String, ccRecipients As String
    Dim cell As Range
    
    ' Set your worksheet (change "Sheet1" to your actual sheet name)
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' Define ranges for To, CC, and email body content
    Set toRng = ws.Range("A2:A10") ' Adjust to your To list range
    Set ccRng = ws.Range("B2:B10") ' Adjust to your CC list range
    Set bodyRng = ws.Range("C2:E10") ' Adjust to your content range
    
    ' Create Outlook object
    Set OutApp = CreateObject("Outlook.Application")
    
    ' Combine all To recipients into a single string (separated by semicolons)
    toRecipients = ""
    For Each cell In toRng
        If cell.Value <> "" Then
            toRecipients = toRecipients & cell.Value & "; "
        End If
    Next cell
    ' Remove the trailing semicolon and space
    If Len(toRecipients) > 0 Then toRecipients = Left(toRecipients, Len(toRecipients) - 2)
    
    ' Combine all CC recipients into a single string
    ccRecipients = ""
    For Each cell In ccRng
        If cell.Value <> "" Then
            ccRecipients = ccRecipients & cell.Value & "; "
        End If
    Next cell
    If Len(ccRecipients) > 0 Then ccRecipients = Left(ccRecipients, Len(ccRecipients) - 2)
    
    ' Create the email
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .To = toRecipients
        .CC = ccRecipients
        .Subject = "Your Subject Here" ' Customize your subject
        .HTMLBody = RangetoHTML(bodyRng) ' Convert cell range to HTML for formatting
        ' Uncomment below if you want to send immediately, or leave as display to preview
        '.Send
        .Display
    End With
    On Error GoTo 0
    
    ' Clean up objects
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    MsgBox "Emails processed successfully!", vbInformation
End Sub

' Helper function to convert cell range to HTML
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    ' Copy the range and create a new workbook to paste the data
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    ' Publish the sheet to an HTML file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    ' Read the HTML file into a string
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    
    ' Clean up
    TempWB.Close savechanges:=False
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Key Changes Explained: #

• Combining Recipients: We loop through your To/CC ranges and build a single string with semicolons (Outlook’s standard separator for multiple addresses), skipping empty cells to avoid formatting issues.
• Preserved Formatting: The RangetoHTML helper function keeps your cell formatting (like colors, fonts, or borders) intact in the email body.
• Flexible Setup: You can easily adjust the toRng, ccRng, and bodyRng variables to match exactly where your data lives in your spreadsheet.

Quick Tips: #

• Test with .Display first to preview emails before switching to .Send to avoid accidental sends.
• Ensure Outlook is open when running the code, or adjust your Outlook security settings to allow VBA access if needed.
• If your recipient lists are longer than A2:A10/B2:B10, just expand those range values to cover all your rows.

Hope this helps you get your emails sent out smoothly! 😊

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