Emailing excel sheets in a workbook to different recipients

[john_sh]

Hi All,

I have found a code to send emails to multiple recipient based on the sheets name and its contents.
the code is working fine but it require some amendments.

i want to add column E (Email addres (CC) ) also i want to keep the information as a table with the preformatted column widths.

I have attached the sample sheet & image of the required output.

hope someone will help me to find a solution.

Thanks

Sub email_location()
Dim lRow As Long
Dim sBody, y As Long, c
Dim sq(), ar, x As Long, j As Long, jj As Long
lRow = Worksheets("Email Address").Cells(Rows.Count, 4).End(xlUp).Row
For Each c In Worksheets("Email Address").Range("D2:D" & lRow).Cells
   sBody = ""
   y = 0
   x = 0
   ReDim sq(x)
   ar = Sheets(c.Value).UsedRange
      For j = 1 To UBound(ar)
         For jj = 1 To UBound(ar, 2)
             If ar(j, jj) <> "" Then
                 ReDim Preserve sq(x)
                 sq(x) = ar(j, jj)
                 x = x + 1
             End If
         Next
     Next
      sBody = "hi, " & c.Offset(0, -3).Value
      Do While y < x
      sBody = sBody & vbNewLine & sq(y)
      y = y + 1
      Loop
    With CreateObject("outlook.application").CreateItem(0)
       .To = c.Offset(0, -1).Value
       .Subject = c.Offset(0, -3).Value & " " & c.Offset(0, -2).Value & " - " & c.Value
       .Body = sBody
       '.Attachments.Add
       .Display '.send
     End With
Next
End Sub