Sub MailToEveryone()
'
' MailToEveryone Macro
' 把工资条通过邮件发给公司的每个人
'
' 快捷键: Ctrl+Shift+E
'要能正确发送并需要对Microseft Outlook进行有效配置
On Error Resume Next
Dim rowCount, endRowNo
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
'取得当前工作表与Cells(1,1)相连的数据区行数
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count - 1
'创建objOutlook应用程序对象
Set objOutlook = New Outlook.Application
Dim body As String
'开始循环发送电子邮件，比如从第一行开始，前十一行是要发送的内容
For rowCount = 1 To endRowNo Step 2
'创建一个objMail为一个邮件对象
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
' .FormDescription = "junzhang@ires.cn"
.To = Cells(rowCount + 1, 12).Value
.Subject = "当月工资条"
' body = Cells(rowCount, 1).Value & Cells(rowCount, 2).Value & Cells(rowCount, 3).Value & Cells(rowCount, 4).Value & Cells(rowCount, 5).Value & Cells(rowCount, 6).Value & _
' Cells(rowCount, 7).Value & Cells(rowCount, 8).Value & Cells(rowCount, 9).Value & Cells(rowCount, 10).Value & Cells(rowCount, 11).Value & vbNewLine & _
' Cells(rowCount + 1, 1).Value & Cells(rowCount + 1, 2).Value & Cells(rowCount + 1, 3).Value & Cells(rowCount + 1, 4).Value & Cells(rowCount + 1, 5).Value & Cells(rowCount + 1, 6).Value & _
' Cells(rowCount + 1, 7).Value & Cells(rowCount + 1, 8).Value & Cells(rowCount + 1, 9).Value & Cells(rowCount + 1, 10).Value & Cells(rowCount + 1, 11).Value & vbNewLine
' body = Range(Cells(rowCount, 1), Cells(rowCount + 1, 11)).Value2
body = Cells(rowCount, 1).Value & "：" & Cells(rowCount + 1, 1).Value & vbNewLine & _
Cells(rowCount, 2).Value & "：" & Cells(rowCount + 1, 2).Value & vbNewLine & _
Cells(rowCount, 3).Value & "：" & Cells(rowCount + 1, 3).Value & vbNewLine & _
Cells(rowCount, 4).Value & "：" & Cells(rowCount + 1, 4).Value & vbNewLine & _
Cells(rowCount, 5).Value & "：" & Cells(rowCount + 1, 5).Value & vbNewLine & _
Cells(rowCount, 6).Value & "：" & Cells(rowCount + 1, 6).Value & vbNewLine & _
Cells(rowCount, 7).Value & "：" & Cells(rowCount + 1, 7).Value & vbNewLine & _
Cells(rowCount, 8).Value & "：" & Cells(rowCount + 1, 8).Value & vbNewLine & _
Cells(rowCount, 9).Value & "：" & Cells(rowCount + 1, 9).Value & vbNewLine & _
Cells(rowCount, 10).Value & "：" & Cells(rowCount + 1, 10).Value & vbNewLine & _
Cells(rowCount, 11).Value & "：" & Cells(rowCount + 1, 11).Value & vbNewLine
.body = body
.Send
End With
Set objMail = Nothing
Next
Set objOutlook = Nothing
End Sub