方案一，CSDN方案¹（win7,outlook2010测试）

功能：

• 可设置变量，替换邮件正文内容；
• 彩色邮件、可换行、表格；（需了解HTML标签）
• 发送不同的附件。

图表如下：

VBA代码如下：

Public Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
 
 
Function WinProcA(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
    KillTimer 0, idEvent
    DoEvents
    Sleep 100
    '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了
    Application.SendKeys "%s"
End Function
 
 
' 发送单个邮件的子程序
Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String)
    Dim objOL As Object
    Dim itmNewMail As Object
    '引用Microsoft Outlook 对象
    Set objOL = CreateObject("Outlook.Application")
    Set itmNewMail = objOL.CreateItem(olMailItem)
    With itmNewMail
        .subject = subject  '主题
        .HTMLbody = body   '正文本文
        .To = to_who  '收件者
        .Attachments.Add attachement '附件
        .Display  '启动Outlook发送窗口
        SetTimer 0, 0, 0, AddressOf WinProcA
    End With
    Set objOL = Nothing
    Set itmNewMail = Nothing
End Sub
 

'批量发送邮件
Sub BatchSendMail()
    Dim rowCount, endRowNo
    Dim newBody
    Dim replaceCount, maxReplaceCount
    Dim pattern
    
    
    Dim i As Integer, j As Integer
    i = Cells(3, 1).Value
    j = Cells(3, 2).Value
    
    '逐行发送邮件
    For rowCount = (i + 4) To (j + 4)
        ' 替换当前行模板内容
        maxReplaceCount = 8   ' 有几个变量就写几
        newBody = Cells(rowCount, 4)
 
        For replaceCount = 1 To maxReplaceCount
            pattern = "[==" & CStr(replaceCount) & "==]"
            newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 5 + replaceCount))
        Next
        ' 替换好了，发邮件咯！
        SendMail Cells(rowCount, 2), Cells(rowCount, 3), newBody, Cells(rowCount, 5)
        
    Next
    Cells(3, 1).Value = i + 5
    Cells(3, 2).Value = j + 5
    
End Sub

注意：

• 正文需用HTML标签， HTML代码可以在W3C school测试效果。

常用HTML标签：

• 段落: <p></p>
• 加粗： <b></b>
• 颜色： <font color="red"></font>

提示：仅仅有 16 种颜色名被 W3C 的 HTML4.0 标准所支持。它们是：aqua, black, blue, fuchsia, gray, green, lime, maroon, navy, olive, purple, red, silver, teal, white, yellow。³

变量部分用[==xxxx==]这样的形式替换掉。注意：中间没有空格。 数字[==1==]会被E列的内容替换掉，[==2==]会被F列的内容替换掉，依此类推，如果有更多，就添加更多列，[==3==], [==4==]等等。

• 附件路径中可以有中文，但是不能有空格。每一行将是一个邮件

为了正确执行代码，还需要在菜工具->引用 中的Microseft Outlook X.0 Object Library  勾选上 （X.0是版本号）

方案二：知乎方案 ² ，结合CSDN （win10,outlook2017测试)

对于excel工作表，从A1开始，可描述题头：第一列：收件人；第二列：主题；第三列：正文；第四列：附件路径； 第五列：变量一； 第六列：变量二

从A2开始，对应题头填写实际收件人，主题，正文，附件路径，变量……

代码如下：

Sub sendBatchMail()
 t = Timer   '计时器开始

Dim rowCount, endRowNo
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
Dim sendIndex
Dim replaceCount, maxReplaceCount
Dim pattern
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count


Set objOutlook = New Outlook.Application

ThisWorkbook.Sheets("sheet1").Select

For rowCount = 2 To endRowNo '循环从第二行运行到最后一行

' 替换当前行模板内容
maxReplaceCount = 2   ' 有几处替换就写几，有2个变量，就写2
newBody = Cells(rowCount, 3)
 
        For replaceCount = 1 To maxReplaceCount
            pattern = "[==" & CStr(replaceCount) & "==]"
            newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount)) ' 从4+N列为变量
                    
        Next
        '替换完毕

Set objMail = objOutlook.CreateItem(olMailItem)
subjectname = ThisWorkbook.Sheets("sheet1").Range("b" & rowCount) '赋值邮件名
bodyname = newBody '赋值邮件正文
attach_address = ThisWorkbook.Sheets("sheet1").Range("d" & rowCount) '赋值附件路径
With objMail
.To = Cells(rowCount, 1)
.Attachments.Add attach_address
.HTMLBody = bodyname
.Subject = subjectname
sendIndex = rowCount Mod objOutlook.Session.Accounts.Count + 1
'要发的邮件分到服务器上
.SendUsingAccount = objOutlook.Session.Accounts.Item(sendIndex)
.Send
End With
Set objMail = Nothing

Application.Wait (Now + TimeValue("0:00:5"))
 '发完一封邮件等5秒左右，时间可以自己调整
Next

MsgBox "发送完毕!" & Chr(10) & "用时" & Timer - t & "seconds" & Chr(10) & "A VBA application modified by colinjiang.com"
 '结束后，显示计时器结果
End Sub

参考文献

1. CSDN． 利用Excel批量快速发送电子邮件 [OL]． https://blog.csdn.net/maray/article/details/8133923
2. 知乎 闲者秋山 ．用Excel和OutLook实现自动批量发邮件[OL]．https://zhuanlan.zhihu.com/p/25283201
3. HTML 颜色[OL].https://www.w3school.com.cn/html/html_colors.asp

在工作簿中插入一个模块。代码如下：

Sub SaveAs()

    On Error Resume Next

    Dim FolderPath As String, FolderName As String, BN As String

    Dim ReturnValue As Integer

    BN = ActiveWorkbook.Name

    FolderPath = ThisWorkbook.Path

    FolderName = Mid(BN, 1, InStrRev(BN, ".", Len(BN)) - 1)

    Dim MyFile As Object

    Set MyFile = CreateObject("Scripting.FileSystemObject")

    If MyFile.folderexists(FolderPath & "\" & FolderName & "-Saved") Then

        ReturnValue = MsgBox("文件夹已存在，是否更新内容？", vbOKCancel, "Caution!")

        If ReturnValue = 2 Then Exit Sub

    Else

        MyFile.CreateFolder (FolderPath & "\" & FolderName & "-Saved")

        Set MyFile = Nothing

    End If

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Dim i As Integer

    For i = 1 To Sheets.Count

        Set Wk = Workbooks.Add

        Workbooks(BN).Sheets(i).Copy before:=Wk.Worksheets("Sheet1")

        Wk.SaveAs FolderPath & "\" & FolderName & "-Saved\" & ThisWorkbook.Sheets(i).Name

        Wk.Close

    Next i

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

End Sub

插入一个按钮并指定按钮至刚才插入的宏代码

点击刚才插入的按钮，运行完毕后可以看到在同目录下出现了一个名称为“拆分工作表-Saved”文件夹，打开文件夹可以看到被拆分出来的若干个工作表。

按ALT+F11，打开VBA编辑器，新建一个模块，把下面的自定义函数代码复制到模块中，关闭VBA编辑器

Function JOINIF(Rng1 As Range, Str, Rng2 As Range)
    Dim arr, brr
    Dim i As Long
    Dim j As Long
    Dim MyStr As String
    If Rng1.Rows.Count > 65536 Then
        arr = Rng1.Resize(65536, Rng1.Columns)
        brr = Rng2.Resize(65536, Rng1.Columns)
    Else
        arr = Rng1
        brr = Rng2
    End If
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                If arr(i, j) = Str Then
                    MyStr = MyStr & brr(i, j) & ","
                End If
            Else
                Exit For
            End If
        Next j
    Next i
    JOINIF = Left(MyStr, Len(MyStr) - 1)
End Function

然后，就可以作为函数正常使用了。

joinif(参数一,参数二,参数三)

第一参数：（必须）条件区域，根据条件计算的单元格区域。区域，绝对引用
第二参数：（必须）用于确定连接的条件。单元格，
第三参数：（必须）要连接的实际单元格区域。

示例

这里我们找家庭账本，点击模板分类中的表单表格——个人，我们发现第一个就是我们要找的，后面还有一些其他样式，可以尝试下载不同模板来满足自己的需求。

我们可以看到这个模板考虑的比较全面，能够我们的一般需求。我们可以把2005年改成现在的年限，每月每日对应的星期也会自动调整。因为作者都已经用函数定义好整个表格，我们最好不要随意的改动。我们要做的只是替换表中的记录为我们的实际记录，该表格将自动为我们算好各种统计值。

本地下载

论文里很重要的一部分时参考文献，如果用手工方法插入则特别麻烦，尤其修改参考文献或者在前面插入新的参考文献时，序号的调整是一件很复杂的事情。如果用word带的尾注功能，则会大大的简化这个问题。

首先把光标置于你想加参考文献的文字后，单击引用选项卡，则会看见下面第二栏的“脚注”。单击右下角的斜箭头符号，打开脚注和尾注的设置窗口。把编码格式选为1,2,3，……点击插入，便可在文字后插入尾注。在文档的后面会出现一条横线，横线下面便是我们的参考文献内容。当你删除原文中的编码时，参考文献也会自动被删除。文档中参考文献编码的顺序也会自动调整，无需我们改动。

这样就大功告成了，但是我们会发现编号没有“[]”，不符合参考文献的要求，我们就需要word中的替换功能。查找尾注标记^e，然后全部替换为[^&]即可（注意用半角）。

再看一遍，还有一个问题，就是尾注前有一条横线删不掉。word2003的解决方法是切换到普通视图，而word2010是没有普通视图的。解决方法： ①将视图改为“草稿” ②ctrl+alt+d调出下方的尾注编辑栏，在下拉菜单中选择“尾注分隔符”，这时短横线出现了，可以将其删除了。