You seem to have a very structured workbook, though I cannot find the custom value for the subject line for the last three sets of data.
Anyway, try this version:
Sub Send_Range_Looping()
Dim aCell As Range
Dim i As Integer
Dim rngB As Range
Dim rngL As Range
Dim Source As Range
Dim OutApp As Object
Dim OutMail As Object
Dim eTo(0 To 10) As String
Dim varSL As Variant
varSL = Array("Barclays", "BNP", "CITINY", "CSFB", "DB", "JPM", "MS", "SABENY", "", "", "")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 10
With Worksheets("Email List")
Set rngB = .Range("B3").Offset(0, i * 3)
Set rngL = .Range(rngB, .Cells(.Rows.Count, rngB.Column).End(xlUp))
For Each aCell In rngL
If aCell <> "" Then
eTo(i) = eTo(i) & aCell & ";"
End If
Next aCell
If Len(eTo(i)) > 0 Then eTo(i) = Left(eTo(i), Len(eTo(i)) - 1)
End With
Set rngB = ActiveSheet.Range("B4").Offset(0, i * 6)
If Not IsEmpty(rngB) Then
Set Source = ActiveSheet.Range(rngB.Offset(-1, -1), rngB.Offset(-1, 3).End(xlDown))
End If
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = eTo(i)
.CC = ""
.BCC = ""
.Subject = "Allocations - " & varSL(i) & Format(Date, " mm/dd/yyyy")
.HTMLBody = RangetoHTML(Source)
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Next i
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
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 workbook to receive 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 .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 the RangetoHTML subroutine.
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.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Other recent topics
