VBA Help

[jason]

I have the below code that looks at a cell and if there is an @ symbol, it
generates an email. I have 7 sheets that have the same people and email
address on them, I want to do a master email address list and not have to
update all 7 sheets. The code works fine when I type the email address in on
each sheet, but when I have it pull the addresses from the master list, the
macro does not work. I am not sure if it is picking up the formula in the
cell and not the contents or what the problem is.


Sub InitialFollowUp()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

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

On Error GoTo cleanup
For Each cell In Columns("d").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "f").Value) = "yes" _
And LCase(Cells(cell.Row, "g").Value) = "" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = Cells(cell.Row, "b").Value
.Subject = "Initial/Follow-Up Feedback Reminder"
.Body = Cells(cell.Row, "c").Value _
& vbNewLine & vbNewLine & _
"You are the supervisor of " & Cells(cell.Row,
"A").Value & " an Initial/Follow-Up feedback is due by " & Cells(cell.Row,
"e").Value & vbNewLine & vbNewLine & "Please us the attached AF Form 931 to
accomplish this feedback. This must be completed by the above date." &
vbNewLine & vbNewLine & "After you have completed your feedback, have the
ratee and yourself sign the attached Feedback MFR and return to the Deputy
Fire Chief." _
& vbNewLine & vbNewLine & _
"Additionally, in accordance with AFI 36-2618,
supervisors are required to provide career counseling to subordinates on the
benefits, entitlements, and opportunities available in an Air Force career.
Counseling occurs in conjunction with performance feedback or when an
individual comes up for review under the Selective Reenlistment Program.
Provide a copy of the attached compensation fact sheet to each individual
after counseling. The fact sheet also contains valuable web links associated
with each topic providing additional valuable information. "


'You can add files also like this
.Attachments.Add ("F:\feedback\Feedback Form.pdf")
.Attachments.Add ("F:\feedback\af931.xfdl")
.Attachments.Add ("F:\feedback\Air Force compensation Fact
Sheet.pdf")
.Display
End With

On Error GoTo 0
Cells(cell.Row, "g").Value = "X"
Set OutMail = Nothing
End If
Next cell

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

 

[joel]

I added thisworkboo.activesheet to the code. Try these changes


Sub InitialFollowUp()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

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

Trailer = "Additionally, in accordance with AFI 36-2618, " & _
"supervisors are required to provide career counseling to subordinates on
the " & _
"benefits, entitlements, and opportunities available in an Air Force
career. " & _
"Counseling occurs in conjunction with performance feedback or when an " & _
"individual comes up for review under the Selective Reenlistment Program.
" & _
"Provide a copy of the attached compensation fact sheet to each individual
" & _
"after counseling. The fact sheet also contains valuable web links
associated " & _
"with each topic providing additional valuable information. "


with thisworkbook.activesheet
On Error GoTo cleanup
For Each cell In .Columns("d").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(.Cells(cell.Row, "f").Value) = "yes" _
And LCase(.Cells(cell.Row, "g").Value) = "" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = .Cells(cell.Row, "b").Value
.Subject = "Initial/Follow-Up Feedback Reminder"
.Body = .Cells(cell.Row, "c").Value _
& vbNewLine & vbNewLine & _
"You are the supervisor of " & _
.Cells(cell.Row,"A").Value & _
" an Initial/Follow-Up feedback is due by " & _
Cells(cell.Row,"e").Value & _
vbNewLine & vbNewLine & _
"Please us the attached AF Form 931 to accomplish
this feedback. " & _
"This must be completed by the above date." & _
vbNewLine & vbNewLine & _
"After you have completed your feedback, have the "
& _
"ratee and yourself sign the attached Feedback MFR
and return to the Deputy " & _
"Fire Chief." & _
vbNewLine & vbNewLine & Trailer


'You can add files also like this
.Attachments.Add ("F:\feedback\Feedback Form.pdf")
.Attachments.Add ("F:\feedback\af931.xfdl")
.Attachments.Add ("F:\feedback\Air Force compensation Fact
Sheet.pdf")
.Display
End With

On Error GoTo 0
.Cells(cell.Row, "g").Value = "X"
Set OutMail = Nothing
End If
Next cell
end with
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub