前一段时间公司在发送每个人工资条时感觉浪费时间，本人就试了一下用excel发送每个人的工资条，简单设计了一个运行后可以实现。操作过程为：点按钮运行宏——excel自动在相应位置创建新的工资表，以各个人员命名，并将原工资表中的标题行及工资内容复制到新建的工资表中——通过outlook实现发送到相应人员工资表。步骤如下：

一、将outlook与用的个人邮箱连接起来。

二、excel宏制作前的准备：1、将需要发送的邮箱收集并复制到相应位置，在此设置到每个人工资的最后

一列；2、在一个盘里面设置一个空文件夹，并在每次发送好邮件时将文件夹里面的内容清空，在此设置

为e:\个人工资。

三、在excel中新建一个宏，代码如下：

Sub 发送每个人的工资条()

Dim intRow1, b As Integer

Dim a As String

  Dim OutlookApp As Object

Dim MailItem As Object

     Windows("发送工资条.xlsm").Activate

    

    

    intRow1 = Worksheets("工资条").Range("c3").CurrentRegion.Rows.Count

   

       

    For b = 3 To intRow1

    a = Cells(b, 3)

    Workbooks.Add

    ChDir "e:\个人工资"

    ActiveWorkbook.SaveAs Filename:="e:\个人工资\" & a & ".xlsx", FileFormat:= _

        xlOpenXMLWorkbook, CreateBackup:=False

        Windows("发送工资条.xlsm").Activate

         Range("A2:z2").Select

    Selection.Copy

     Windows(a & ".xlsx").Activate

        ActiveSheet.Paste

         Application.CutCopyMode = False

             Windows("发送工资条.xlsm").Activate

        Worksheets("工资条").Range(Cells(b, 1), Cells(b, 26)).Select

    Selection.Copy

      Windows(a & ".xlsx").Activate

      Range("A2").Select

     ActiveSheet.Paste

           

    ActiveSheet.Paste

    ActiveWorkbook.Save

    ActiveWindow.Close

    Windows("发送工资条.xlsm").Activate

 Set OutlookApp = CreateObject("Outlook.Application")

    Set MailItem = OutlookApp.CreateItem(0)

    MailItem.To = Cells(b, 27)               '收件人

    MailItem.cc = Cells(1, 2)                  '抄送

    MailItem.Subject = Cells(1, 3)            '主题

    MailItem.Body = Cells(1, 4)                '正文

    MailItem.Attachments.Add Sheets("工资条").Cells(b, 28).Value                 '附件 路径

    MailItem.Send

    Set OutlookApp = Nothing

    Set MailItem = Nothing

        

    Next

        

End Sub

四、参考图补充细节

http://s7/mw690/001lJxhdzy7cduRSVKK56&690