georgefreight
New Member
- Joined
- Sep 21, 2015
- Messages
- 15
Thanks all for help with this macro last week, its being pieced together slowly from multiple sources
Currently I have about 300 rows of data, however when I have gone to send it the macro was only sending emails for up to row 133.
I can't see any limit in the code but am unsure if outlook has a limit on emails it sends, my PC isn't up to sending 300 emails or there is a limit placed by the IT dept.
The reason I want it to send all the emails at once is that there is another macro that runs to create quotes for all the data and I wanted them to both run off the same worksheet.
I've tried to incorporate the following into the code so I can select it to run eg 50 lines at a time but whilst it prompted me to enter the lines it still runs through the full sequence.
Can someone show me how to use the lines below in the macro so it only works through the chosen rows not the entire sheet.
Dim SR As Long
Dim LR As Long
SR = Val(InputBox("Enter First Row"))
LR = Val(InputBox("Enter Last Row"))
Currently I have about 300 rows of data, however when I have gone to send it the macro was only sending emails for up to row 133.
I can't see any limit in the code but am unsure if outlook has a limit on emails it sends, my PC isn't up to sending 300 emails or there is a limit placed by the IT dept.
The reason I want it to send all the emails at once is that there is another macro that runs to create quotes for all the data and I wanted them to both run off the same worksheet.
I've tried to incorporate the following into the code so I can select it to run eg 50 lines at a time but whilst it prompted me to enter the lines it still runs through the full sequence.
Can someone show me how to use the lines below in the macro so it only works through the chosen rows not the entire sheet.
Dim SR As Long
Dim LR As Long
SR = Val(InputBox("Enter First Row"))
LR = Val(InputBox("Enter Last Row"))
Code:
Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strbody As String
MsgBox "make sure you have Outlook open and that you want to send a lot of emails out, if not, panic"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = ActiveWorkbook.ActiveSheet
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("d").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("c1:ac1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
strbody = "<HTML><BODY>"
strbody = "Hi " & cell.Offset(0, -2).Value & _
"<br><br>Attached are current rates which in the main are valid until the end of " & sh.Cells(1, 15) & _
"<br><br>" & sh.Cells(1, 16) & _
"<br><br>We shall as always keep you informed of fluctuations in the market.<br>" & _
"<br>We are here to help, so please call.<br>" & _
"<br>Don't forget we also operate a market leading LCL service that offers fast transits at very competitive 'All In' prices.<br>" & _
"<br>We operate comprehensive road freight services - they range as far as Morocco to the south and Turkey to the east. We offer daily departures both import and export on many routes including Turkey - We look forward to receiving your enquiries. Please find more info in our Brochure linked below" & _
"<br><A href=http://content.yudu.com/Library/A31yri/EuroTransitGuide/resources/index.htm>Davies Turner Overland Brochure</A <br>" & _
"<br>Kind Regards" & _
"<br>george" & _
"<br><br><br><B/>Bristol Sales Team</B><br>" & _
"<br><B/>Davies Turner & Co Limited</B>" & _
"<br>Western Freight Terminals, Avonmouth, Bristol, BS11 8DT" & _
"<br>T +44 117 982 8341 | Bristol Sales@daviesturner.co.uk" & _
"<br>Visit us at <A href=http://www.daviesturner.com> www.DaviesTurner.com" & _
"<br><a href=http://content.yudu.com/Library/A31yri/EuroTransitGuide/resources/index.htm>Overland | </A <a href=http://content.yudu.com/Library/A2ykf5/Oceanfreight/resources/index.htm>Sea | <a href=http://www.daviesturner.com/images/stories/brochures/Air.pdf>Air | <a href=http://content.yudu.com/web/3wv2v/0A3wwxy/Supplychain/flash/resources/index.htm?referrerUrl=http%3A%2F%2Fcontent.yudu.com%2Fweb%2F3wv2v%2F0A3wwxy%2FSupplychain%2Findex.html>Logistics</a <BR>" & _
"<br><font color=""black""><B/>EORI No : GB235674645032 | AEO No : GB AEOF 00035/09</B><\font>" & _
"<br><br>If you no longer wish to receive our latest rates, just reply to this email and we will remove you from the list"
strbody = strbody & "</BODY></HTML>"
On Error Resume Next
With OutMail
.to = cell.Value
.Subject = "Monthly Tariff"
.HTMLBODY = strbody
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
.SentOnBehalfOfName = """Bristol Sales"" <bristolsales@daviesturner.co.uk>"
.Display
'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"
'Or use .Display or .send (the previous 2 lines will have apostrophe removed when display is changed to send)
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
