PDA

View Full Version : Loop thru excel workbook and send sheets not working



austenr
07-27-2015, 07:11 AM
In the attached workbook I have 8 sheets not including the "Master Sheet". I have the names of the recipients in column X, email address in Column Y and whether to send it in column Z. I need a way to loop thru and grab each email address from the master sheet and send it to the recipient from the list in column Y. Also I am not sure if the code I currently have will copy what is on each sheet and paste it into the body of the Outlook email. Thanks for looking.


Sub SendWorksheets()'Sends workshets to SET menbers via Outlook
Dim OutApp As Object
Dim OutMail As Object
Dim WSCount, I As Integer
Dim cell As Range
Dim rngBody As Range



Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
WSCount = ActiveWorkbook.Worksheets.Count
For I = 1 To WSCount
For Each cell In Sheets("Sheet1").Select("Y").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "Z").Value) = "yes" Then


Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
Set rngBody = .Range(.Range("A2"), .Range("H2").End(xlDown))
.To = cell.Value
.Subject = "Travel Exceptions"
.Body = "Dear " & Cells(cell.Row, "X").Value _
& vbNewLine & vbNewLine & _
"Here are the exceptions for your group for booking travel less than 13 days in advance " & _
"please review"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
Next I


cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
:dunno

austenr
07-27-2015, 09:20 AM
After stepping thru the code my for loop terminates on this line:


For Each cell In Sheets("MasterSheet").Select("Y").Cells.SpecialCells(xlCellTypeConstants)

austenr
07-27-2015, 10:20 AM
This works except for copying and pasting the data from the current sheet to the email.


Sub SendWorksheets()
'Sends workshets to SET menbers via Outlook
Dim OutApp As Object
Dim OutMail As Object
Dim WSCount, i As Integer
Dim cell As Range
Dim rngBody As Range




Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
WSCount = ActiveWorkbook.Worksheets.Count
For i = 1 To WSCount
For Each cell In Sheets("MasterSheet").Range("SetMemberAddress")
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "Z").Value) = "yes" Then


Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
rngBody = Worksheets(i).Range(Range("A2"), .Range("H2").End(xlDown))
Set .Body = .rngBody
.To = cell.Value
.Subject = "Travel Exceptions"
'.Body = ActiveSheet.Range("A2:H2").Select
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
Next i

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub