How to CC multiple recipents?

[sharkey]

Good evening all,

I'm working on a file that automatically sends two files to multiple To: recipients, based off of emails in column I, I'd like to also CC: the emails in columns J and K (because those will vary depending on the recipient) but I have no idea how to do that. Any help would be greatly appreciated!

The code is below and I've included my working file, I'm sure it's an easy solution and I'm probably just inept.

Thanks in advance!

Sub Send_Files()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

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

    Set sh = Sheets("Distribution List")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("I").Cells.SpecialCells(xlCellTypeConstants)

        Set rng = sh.Cells(cell.Row, 1).Range("L1:M1")

        If cell.Value Like "?*@?*.?*" And _
          Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
           
            strbody = Range("C5")
            strsigned = Range("C6")
                         
            With OutMail
                .To = cell.Value
                .CC = ThisWorkbook.Sheets("Distribution List").Range("J1").Value
                .Subject = "Renewals Data"
                .Body = Cells(cell.Row, "F").Value & "," & vbNewLine & vbNewLine & strbody & vbNewLine & vbNewLine & "Thanks," & vbNewLine & strsigned

            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

[Smallman]

Try this

Sub Send_Files()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
 
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    Set sh = Sheet1
    Set OutApp = CreateObject("Outlook.Application")
   
    For Each cell In sh.Columns("I").Cells.SpecialCells(2)
        Set rng = sh.Cells(cell.Row, 1).Range("L1:M1")
        If cell.Value Like "?*@?*.?*" Then 'And _
          Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
 
            With OutMail
                .To = cell.Value
                .CC = cell.Offset(, 1) & ";" & cell.Offset(, 2)
                .Subject = "Renewals Data"
                .Body = Cells(cell.Row, "F").Value & "," & vbNewLine & vbNewLine & sh.[C5] & vbNewLine & vbNewLine & "Thanks," & vbNewLine & sh.[C6]
            For Each FileCell In rng.SpecialCells(2)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then .Attachments.Add FileCell.Value
                    End If
            Next FileCell
                .Send
            End With
 
            Set OutMail = Nothing
        End If
    Next cell
 
    Set OutApp = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
End Sub

 

[sharkey]

@Smallman thank you! That makes total sense. You = awesome

 

[Smallman]

Haha - nice touch Sharkey. Thanks a lot.

Smallman

 

[abhijeet gaddam]

hi thanks for code.

how can i will get same format in body as same in excel cell eg:- bold, font size & font colour.