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
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