How to use a Macro to send worksheets??

[Andy Langenfeld]

I was given the code below which automatically sends personalized Outlook emails directly from an Excel workbook. The Excel worksheet has the email address of each individual who receives an email, but I'd like to modify it so that each email recipient also receives an attached Excel worksheet from that same workbook.

I'd like to modify the code so that it attaches each respective worksheet (within the same workbook) automatically to each email recipient. In other words, Sheet1 would be sent as an attachment to Person1, Sheet2 would be sent as an attachment to Person2, etc. I don't know how to modify the Macro to address the attached worksheet scenario. If any one can help me, it would be greatly appreciated. Thanks in advance.

Sub SendProductionReports()
Dim rngStatus As Range
Dim lngRow As Long
Dim lngRes As Long
Dim objOL As Outlook.Application

On Error GoTo ErrorHandler

Set rngStatus = Names("Status").RefersToRange
For lngRow = 1 To rngStatus.Rows.Count
If rngStatus(lngRow).Text = "RUN" Then
lngRes = Send_Msg(lngRow, objOL)
If lngRes = 429 Then
'Log inability to continue because
'can't open Outlook.
Exit For
End If
End If
Next lngRow
ProcExit:
On Error Resume Next
'objOL.Quit
Set objOL = Nothing
Exit Sub
ErrorHandler:
'Log Errors (not shown here)
MsgBox ("Error: " & Err.Number & _
": " & Err.Description)
Resume ProcExit
End Sub

Function Send_Msg(lngRow As Long, _
objOL As Outlook.Application) As Long
Dim objMail As MailItem
Dim lngRes As Long

On Error GoTo ErrorHandler
lngRes = 0
If objOL Is Nothing Then
Set objOL = New Outlook.Application
End If
Set objMail = objOL.CreateItem(olMailItem)
With objMail
.To = Cells(lngRow, 3)
.Subject = "Test"
.Body = "Hello " & _
Cells(lngRow, 2) & " " & _
Cells(lngRow, 1) & _
":" & vbCrLf & _
"You are one of " & _
Cells(lngRow, 5) & _
" clinic employees receiving this email automatically" & "." & _
" Please contact me once you've received it, then you can delete it." & _
" Thanks for your help."
'.Display 'For debug purposes
.Send
End With

ProcExit:
On Error Resume Next
Send_Msg = lngRes
Set objMail = Nothing
Exit Function
ErrorHandler:
lngRes = Err.Number
'Log errors (not shown here)
MsgBox ("Error: " & lngRes & ": " & Err.Description)
Send_Msg = lngRes
Resume ProcExit
End Function