title: Send Range of Cells to Multiple Recipients
body: <p>I am new to this, so please bear with me. I am trying to send a specified range of cells to different contacts on a loop. So far, this is operational for 1 contact per email. Is there a way to modify this code to send the email to multiple individuals from a spreadsheet along with having multiple individuals from the same sheet on cc? </p>
  
  <p>Please note, I pieced together much of the below code from Ron Debruin's site</p>
  
  <pre><code>Sub Send_Row_Or_Rows_1()
  
      Dim OutApp As Object
      Dim OutMail As Object
      Dim rng As Range
      Dim Ash As Worksheet
      Dim Cws As Worksheet
      Dim Rcount As Long
      Dim Rnum As Long
      Dim FilterRange As Range
      Dim FieldNum As Integer
      Dim mailAddress As String
      Dim StrBody As String
  
  
  
      On Error GoTo cleanup
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
  
      With Application
          .EnableEvents = False
          .ScreenUpdating = False
      End With
  
      'Set filter sheet, you can also use Sheets("MySheet")
      Set Ash = ActiveSheet
  
      'Set filter range and filter column (Column with names)
      Set FilterRange = Ash.Range("A1:H" &amp; Ash.Rows.Count)
      FieldNum = 1    'Filter column = A because the filter range start in A
  
      'Add a worksheet for the unique list and copy the unique list in A1
      Set Cws = Worksheets.Add
      FilterRange.Columns(FieldNum).AdvancedFilter _
              Action:=xlFilterCopy, _
              CopyToRange:=Cws.Range("A1"), _
              CriteriaRange:="", Unique:=True
  
      'Count of the unique values + the header cell
      Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
  
      'If there are unique values start the loop
      If Rcount &gt;= 2 Then
          For Rnum = 2 To Rcount
  
              'Filter the FilterRange on the FieldNum column
              FilterRange.AutoFilter Field:=FieldNum, _
                                     Criteria1:=Cws.Cells(Rnum, 1).Value
  
              'Look for the mail address in the MailInfo worksheet
              mailAddress = ""
              On Error Resume Next
              mailAddress = Application.WorksheetFunction. _
                            VLookup(Cws.Cells(Rnum, 1).Value, _
                                  Worksheets("Mailinfo").Range("A1:C" &amp; _
                                  Worksheets("Mailinfo").Rows.Count), 2, False)
              On Error GoTo 0
  
              If mailAddress &lt;&gt; "" Then
                  With Ash.AutoFilter.Range
                      On Error Resume Next
                      Set rng = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
                  End With
  
                  Set OutApp = CreateObject("Outlook.Application")
                  Set OutMail = OutApp.CreateItem(0)
  
    StrBody = "&lt;BODY style=font-size:11pt;font-family:Calibri&gt;Dear team, &lt;br&gt;&lt;br&gt;" &amp; _
                "Please see below for this week's data queries.&lt;br&gt;&lt;br&gt;"
  
                  On Error Resume Next
                  With OutMail
                      .display
                      .To = mailAddress
                      .bcc = "emily_thomas@virtualscopics.com"
                      .Subject = "CA209-915 BioTel Research Weekly Queries"
                      .HTMLBody = StrBody &amp; RangetoHTML(rng) &amp; .HTMLBody
                      .Attachments.Add ("\\corp.virtualscopics.com\org\Dept\Project Management\Team\Projects\33320 - BMS - CA209-915\Signed Documents\Site Documents\All Approved Site Docs and Approval Forms\33320_ct_mri_subject_data_transmittal_form_v1.1.pdf")
                      .display  'Or use Send
                  End With
                  On Error GoTo 0
  
                  Set OutMail = Nothing
                  Set OutApp = Nothing
              End If
  
              'Close AutoFilter
              Ash.AutoFilterMode = False
  
          Next Rnum
      End If
  
  cleanup:
      Set OutApp = Nothing
      Application.DisplayAlerts = False
      Cws.Delete
      Application.DisplayAlerts = True
  
      With Application
          .EnableEvents = True
          .ScreenUpdating = True
      End With
  End Sub
  
  Function RangetoHTML(rng As Range)
  
      Dim fso As Object
      Dim ts As Object
      Dim TempFile As String
      Dim TempWB As Workbook
  
      TempFile = Environ$("temp") &amp; "/" &amp; Format(Now, "dd-mm-yy h-mm-ss") &amp; ".htm"
  
      'Copy the range and create a new workbook to past the data in
      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 a htm 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 all data from the htm file into RangetoHTML
      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=")
  
      'Close TempWB
      TempWB.Close savechanges:=False
  
      'Delete the htm file we used in this function
      Kill TempFile
      Set ts = Nothing
      Set fso = Nothing
      Set TempWB = Nothing
  End Function
  </code></pre>