告别996之最实用VBA办公自动化代码大全详解

简介

本人日常办公中使用VBA实现办公自动化已经有较长时间，积累了一定的经验，在此总结分享出来，希望对大家有所启发。
Excel的录制宏代码可以解决大部分的办公自动化需求，但是依然有很多录制下来的代码使用起来不是很方便，如果对某些片段进行修改，往往会隐藏各种各样的bug，因此需要对常见的语句进行学习和了解，后面对其进行修改和优化才能保证代码的稳定性。
本文尽量分享的是一些自动化办公中最常用的功能代码的使用方法，比如说打开文件、筛选区域，判断区域行数，动态选择区域、发送邮件等，以下为文章主要内容，后续会完善更新，还请多多收藏关注。

目录

• 自动化的起点之打开文件
• 使用 AutoFilter 对指定区域筛选
• 判断某区域第一行或最后一行的行号
• 使用 AutoFill 填充指定区域
• 窗口的激活、关闭以及工作表的选择
• 日期设置与Offset实现偏移
• 发送邮件这件事

打开文件

首先获取VBA代码执行文件的相对路径（一般是保存了宏代码的xlsm文件）

Path = ThisWorkbook.Path

打开文件

Workbooks.Open ("" & Path & "\" & "我的工作簿.xlsx")

该方法实际有两个参数：
FileName String 类型，必需。要打开的工作簿的文件名。
UpdateLinks Variant 类型，可选。指定文件中链接的更新方式。如果省略本参数，则提示用户选择链接的更新方式。否则，该参数的取值应为下表中的某个值。
UpdateLinks值含义：
0 不更新任何引用。
1 更新外部引用，但不更新远程引用。
2 更新远程引用，但不更新外部引用。
3 同时更新远程引用和外部引用。

但是有时候我们希望能打开模糊匹配的文件，可以借助通配符*，像下面这样。

Workbooks.Open ("" & Path & "\" & Dir("" & Path & "\" & "我的*.xls"))

有时候我们打开一个Excel文件 ，提示“此工作簿包含到一个或多个可能不安全的外部数据源的链接……”，问你是否更新，这个弹窗会阻断我们的VBA进程，我们可以在打开文件的时候设定不更新

Dim wb As Workbook
'UpdateLinks:=0 不更新链接
Set wb = Workbooks.Open(Filename:="" & Path & "\" & Dir("" & Path & "\" & "我的*.xls"), UpdateLinks:=0)

对指定区域进行筛选

很多时候，我们要处理的数据需要先进行一个筛选，创建一个筛选的代码长这样：

ActiveSheet.Range("$A$1:$W$100" ).AutoFilter Field:=1, Criteria1:= _
        ">=10"  Operator:=xlAnd, Criteria2:="<=100" 

这段代码的含义是，筛选活动表的"A1:W100"这个区域，" Field:=1"表示筛选条件位于所选区域的第一列。Criteria后面跟的是一系列条件。这种筛选语句可以有多条，则选取需要满足多条筛选语句。

判断某区域的最后一行（行号）

判断一般区域

如果判断普通区域（非筛选状态），没有隐藏行，可以用下面的语句简单判断最后一行数据行号：
思路是先取消可能存在的筛选，然后选择一个单元格（选择的单元格需保证到该列的最后一行之间不存在间断，否则会出错）

'清除筛选
ActiveSheet.AutoFilterMode = False
'计算需要填充行数
Range("A2").Select
'跳到该单元格所在列的最后一行
Selection.End(xlDown).Select
a = ActiveCell.Row()
b = CStr(a) '数字转文本类型，即为选取最后一行行号

判断筛选状态区域第一行行号

更多的情况下，我们需要判断筛选后的第一行的行号才可以对该区域进行操作（一般是执行复制），可以采用以下代码：

n = Rows("2:" & Rows.Count).SpecialCells(12).Row

此句拆分一下，Rows(“2”&Rows.Count)选择从第2行开始到最后一行的区域，后面加上.specialCells(12)表示只选可见行，最后在加上区域的Row属性。返回可见区域第一行的行号。

填充指定区域

有时候需要填充指定区域（很多时候是类似公式的下拉操作）

'选择填充开始位置
Range("U2:W2").Select
Application.CutCopyMode = False
'填充到最后一行
Selection.AutoFill Destination:=Range("U2:W100" )

窗口激活、关闭，工作表的选择

'激活"我的工作簿.xlsx“窗口（前提是已经打开改文件）
Windows("我的工作表.xlsx").Activate
'关闭活动窗口的文件
ActiveWindow.Close
'选择指定工作表
Sheets("Sheet1").Select
'或者另一种方式，选“第1个“”sheet
Sheets(1).Select

有时我们需要判断一个工作簿里面的哪个子表才是我们需要的，我们可以遍历选择每个子表以此判断。

'判断子sheet是否为需要的
For i = 1 To Worksheets.Count
Sheets(i).Select
'写判断条件，满足了就退出循环不继续切换子表，否则一直看到最后一个子表
If Range("A1") = "日期_day" Then Exit For
Next

日期选择与偏移位置

有时候，我们需要动态更改报表里面的日期，需要用到日期函数，以及对日期进行偏移（一周，一月等）。
下面有一个案例：

'今日日期
td = Date
'设置基础日期
basedate = CDate("2021-11-1")
Sheets("累计").Select
'在基础日期上偏移当前日期的天数
Range(Range("GD1").Offset(0, DateDiff("D", basedate, td) - 1), Range("GD1").Offset(0, DateDiff("D", basedate, td) - 1).Offset(72, 0)).Select
Selection.Copy
Range("GD1").Offset(0, DateDiff("D", basedate, td) - 1).Select

Date函数可以返回当前日期，而借助Datediff函数可以计算出偏移后的日期，最后再借助offset函数，即可实现对指定选区的偏移操作。

发送邮件

发送邮件模块可以这样写：

'发邮件模块
Sub SendEmail(To_Addr As String, Cc_Addr As String, Bcc_Addr As String, SubjectText As String, BodyText As String, AttachedObject As String)
    Dim OutlookObj As Object
    Dim OutlookNewMail As Object
    
    '创建Outlook对象
    Set OutlookObj = CreateObject("Outlook.Application")
    Set OutlookNewMail = OutlookObj.CreateItem(olMailItem)
    
    '错误异常处理
    On Error GoTo SendEmail_Failed
    
    With OutlookNewMail
        .To = To_Addr                   '收件人地址
        .cc = Cc_Addr                   '抄送人地址
        .BCC = Bcc_Addr                 '密送人地址
        .Subject = SubjectText          '邮件主题
        .htmlBody = BodyText                '邮件内容
        .Attachments.Add AttachedObject '粘贴附件
        
        '.Send                          '若采用.Send方式发送邮件，则Outlook容易出现“有一个程序正试图以您的名义发送电子邮件”提示，比较招人讨厌。
                                        '若坚持采用此种方式发送邮件，又不想Outlook出现讨厌的提示，则需对Outlook进行如下设置：
                                        '"工具" -> "信任中心" -> "编程访问" -> 选择"从不向我发出可疑活动警告"
    End With
    
    '以下是采用通过激活Outlook，然后模拟按键方式进行邮件发送
	SendEmail_Sending:
    '显示发送邮件窗口
    OutlookNewMail.display
   
    '以下目的是留给系统充分的时间点击发送键
    For j = 1 To 200
        DoEvents
    Next
    
    '点击邮件发送
    SendKeys "%s", Wait:=True
    '遗憾的是，这里无法显示服务器发送状态，只能返回Excel发送的结果
    MsgBox "邮件已发送！"
    Exit Sub
  
	SendEmail_Failed:
    MsgBox "发送失败，原因为：" & Err.Description
    Exit Sub
    
End Sub
'调用部分
 '简单调用示例，调用中各参数分别为："收件人","抄送人","密送人","主题","正文","附件"。
SendEmail "[email protected]", "", "", "数据表", "本月数据表，请查收！", "D:\Users\lindada\Desktop\我的工作表.xlsx"

以上邮件模块已经可以发送简单的文字邮件+附件了，但是我们日常工作中发的邮件一般是数据日报，不仅文字需要带一定的格式，邮件还会附带图片，这种需要将正文内容以HTML文档的格式编辑好放进正文里即可。
如下面一段HTML格式的正文:

<body style='font-family:微软雅黑;font-size:13px;'>
	各位领导好，数据达成如下：
	<br/>
	1、整体情况，XXXXX；
	<br/>
	2、产品维度,XXXX；
	<span style='color:red'>
		达成较差的为：张三、李四、王五；
	span>
	<br/>
	<img src='D:\Users\test\日报截图.jpg'>
body>

图文都有了，也有了格式设置，那么每次还需要将报表图片导出，就非常的麻烦，下面一段代码则可以将指定区域的内容提取为图表并导出：

 a = ThisWorkbook.Path
 '打开当前文件路径下的看板
 Workbooks.Open ("" & a & "\" & "日报看板.xlsx")
 选择看板窗口
 Windows("日报看板.xlsx").Activate
'选择要发邮件的图表在的子表
 Sheets("邮件").Select
 '有时候会发现截出来的图片很大，可以模拟滚轮操作，将图片缩放到35%
 ActiveWindow.Zoom = 35
 '选择要导出为图片的区域
 Range("B2:V79").Select
 Selection.Copy
 Selection.CopyPicture
 With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    .Parent.Select
    .Paste
    .Export "D:\test\日报看板.jpg", "JPG"
    .Parent.Delete
 End With

小结

以上是本人办公自动化用到最多的结构，其余的常见用法，比如说跳转单元格的位置，复制，粘贴等均可以通过录制宏代码后进行稍加改进，本文暂时写到这里，后续有新的感想会更新，感谢各位！