日报标题：职场新人的福利，学好了，要做一小时的表格几分钟就搞定
知乎用户，BI开发/数据挖掘/CPDA
看到这个话题，我决定送给职场新人一个福利~~
我刚毕业那会，Excel 数据透视表都不会，后来进入 DBA 部门用得更少了。
工作过程中一个做 Excel 的妹子找我抱怨，做一个表要花一两个小时，甚至三四个小时，请教我能否想想办法，我用 R 写个程序可以。考虑到妹子家里公司都要做事，不太想安装 R。我想到了 VBA，在大学时学过一点 VB，正好练练手。
花一天整理妹子的需求，用一周学习，然后就写出了
3 个自定义函数
2 个自动更新数据
后来写着写着就顺手，经常帮妹子写报表自动化程序。
导致妹子对我产生依赖性，她每天就想按几个键然后工作都完成了。
我建议她可以看看我的代码，我都写好注释了，你可以按照注释去改参数，就不用天天问我了，但妹子看不懂，我教了几遍遂放弃。
对了上面说的福利，当然是贴代码，这份福利给文职类的处理 Excel 的新人，程序员不要捣乱。
情景 1：一个工作簿，你按照地区或者部门等你自己的需要拆成不同的工作簿（需求是不是很简单，nonono，单独做一个当然简单，但是我贴出来肯定是这个代码是通用的。比如你想拆第几行开始娜一列都可以，会有选项让你一步一步选择）
情景 2：比如拆完，有 30 张表，你想发给 30 个不同的人看？你是不是要同时写 30 封邮呢
关于情景 1 的工作时间：如果一张总表有三十城市，要按照城市拆成三十个工作簿，不断复制 + 改工作簿名，个人觉得至少得二十分钟吧，还有容易出错的概率。
关于情景 2 的工作时间：这个就更麻烦了。三十个城市名，要下发给三十个不同分公司的人，而且不同分公司的人，不是只有一个人。你第一次发，如果邮箱有群组还好，但是你始终得写三十封邮件，还要注意选择工作簿不能出错，邮件主题内容不能出错。预估这个工作时间至少得一个小时，平均一封邮件 2 分钟。
情景 1+ 情景 2 时间=一小时二十分钟（据我观察，历史五个人做这件事出错率 100%，不是城市名写错了，就发错工作簿了）
不知道大家看懂了没= =
好了开始写步骤贴代码，我会尽量用最通俗的语言讲清逻辑关系
步骤 1：建立两个 sheet，点击 sheet ，右击查看代码（先检查 Excel 是否启用宏，要启用宏哦）
插入窗体和模块，按模块，把以下这串代码复制进去
再按窗体，设置成这样
然后看到代码，拉到最后，能看到一个是邮件签名，一个是邮箱配置，你自己填上即可，邮件内容可以自己改
截止到这步，代表所有准备工作都完成了，咱们开始测试吧^_^
29 个城市，我拆成 29 个工作簿，点击宏
按完确定大概 10 秒后，跟你 Excel 同个文件夹内，会生成拆分的文件夹，你点进去
已经生成了，如果没有想要发邮件的同学，在这里就可以结束啦。
打开工作簿看看，拆分如何
想把三十个工作簿发送邮件的同学，注意看下面，转到通讯录的那个 sheet，
这里点击一次文件夹，直接按确定，不用双击进入文件夹
按完确定后，这时候按照工作簿数来算时间，基本上每秒一个城市，也就是一个工作簿。等到这个提示出来之后，你就可以直接看到结果了。
然后你在看，是否有收到邮件
打开你的邮箱
收到啦
整套点击 + 运行大约三分钟
代码：
Sub 通用拆分()
'On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
Application.DisplayAlerts = False '关闭提示事件,防止删除表格时提示
Dim Pro, Wb1, Wb2, St1, Sht, Rng, Itm, StRow, Pth
Set Wb1 = ThisWorkbook
Set St1 = ActiveSheet
a = MsgBox("当前文件为：" & Wb1.Name & Chr(10) & "当前表格为：" & St1.Name & Chr(10) & Chr(10) & "点击 确定 继续运行，" & Chr(10) & "点击 取消 退出程序。", 1)
If a = 2 Then '如果点了取消,就退出程序
Exit Sub
End If
b = InputBox("请输入拆分列表头所在的单元格位置。" & Chr(10) & "例如：要拆分的列位于 C 列，表头是第 3 行，就输入“C3”")
If b = "" Then
MsgBox ("未输入拆分表头，程序退出")
Exit Sub
End If
rowx = St1.Range(b).Row
colx = St1.Range(b).Column
Set Pro = CreateObject("Scripting.Dictionary") '建立一个以省份为关键字的字典
StRow = St1.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.Row '确定当前文件行数
St1.Range(rowx & ":" & rowx).AutoFilter Field:=colx, Criteria1:="*" '取消筛选
For Each Rng In St1.Range(St1.Cells(rowx + 1, colx), St1.Cells(StRow, colx)) '
If Not Pro.exists(Rng.Value) And Not IsError(Rng.Value) Then Pro.Add Rng.Value, Rng.Value '判断当前表格的值是否在字典内,如果不在,就添加到字典内
Next
namex = InputBox("请输入文件名的自定义字段，" & Chr(10) & "例如输入“收款明细”,就会生成“上海 - 收款明细.xlsx”文件", "", St1.Name)
For Each Itm In Pro.Items '针对字典内的每个值进行一次操作(每个省份循环一次)
St1.Copy
Set Wb2 = ActiveWorkbook
Set Sht = ActiveSheet
Sht.Range(rowx & ":" & rowx).AutoFilter Field:=colx, Criteria1:="<>" & Itm, Operator:=xlAnd '筛选列,筛选值为不符合当前省份
Sht.Range(Sht.Cells(rowx + 1, colx), Sht.Cells(StRow, colx)).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp '删除被筛选出来的行(删掉不为当前省份的行)
Sht.Range(rowx & ":" & rowx).AutoFilter '取消筛选
ActiveWindow.SmallScroll Down:=-StRow
ActiveWindow.SmallScroll ToRight:=-100
If Dir(Wb1.Path & "\拆分\", vbDirectory) = "" Then MkDir ThisWorkbook.Path & "\拆分\" '看看当前文件夹内是否存在"拆分"文件夹,如果没有就创建一个
Pth = Wb1.Path & "\拆分\" & Itm & "-" & namex & ".xls"
Wb2.SaveAs Filename:=Pth, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Wb2.Close '关闭表格
Next
Set Pro = Nothing '释放变量
Set Wb1 = Nothing
Set Wb2 = Nothing
Set St1 = Nothing
Set Sht = Nothing
Set Rng = Nothing
Set Itm = Nothing
Set StRow = Nothing
Set Pth = Nothing
Application.ScreenUpdating = True '打开屏幕更新
Application.DisplayAlerts = True '打开提示事件
End Sub
Sub 通用发送邮件()
'On Error Resume Next
Dim cm As Variant
UserForm1.Show
UserName = UserForm1.ComboBox1
UserPass = UserForm1.TextBox1.Value
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & "\"
If .Show = -1 Then
Pth = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems.Item(1) & "\"
End If
End With
'定义文件夹
Dim FS, F, FF, Fil, BName, EName
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.GetFolder(Pth)
Set FF = F.Files
If FF Is Nothing Or F Is Nothing Then
MsgBox ("文件或文件夹错误,请查证在本文件目录内存在'拆分'文件夹,并且已经生成拆分文件")
Exit Sub
End If
'保存文件信息
Dim FN(1 To 10000, 1 To 3)
i = 0
For Each Fil In FF
i = i + 1
FN(i, 1) = FS.GetBaseName(Fil)
FN(i, 2) = FS.GetExtensionName(Fil)
FN(i, 3) = Left(FN(i, 1), InStr(1, FN(i, 1), "-") - 1)
Next
Set Sht = ThisWorkbook.Sheets("邮件联系人")
colnew = Sht.Cells(1, Columns.Count).End(xlToLeft).Column + 1 '联系人空白列(用于记录发送结果)
Sht.Cells(1, colnew).Value = Pth & Chr(10) & Date & " " & Time & " 发送结果"
tex = InputBox("请输入邮件正文自定义段")
For m = 1 To i
Err.Clear
linkman = ""
emailx = ""
Set bbb = Sht.Range("a:a").Find(FN(m, 3))
If bbb Is Nothing Then
rownew = Sht.Range("a60000").End(xlUp).Row + 1
Sht.Cells(rownew, 1).Value = FN(m, 3)
Sht.Cells(rownew, colnew).Value = "未找到发件人"
mg = mg & FN(m, 3) & Left(" ", 10 - Len(FN(m, 3)) * 2) & "未找到发件人" & Chr(13)
GoTo line5
End If
For n = 1 To Sht.Range("a60000").End(xlUp).Row '循环查找联系人姓名和邮件地址
If FN(m, 3) = Sht.Cells(n, 1).Value Then
linkman = linkman & Sht.Cells(n, 2).Value & "、"
emailx = emailx & Replace(Sht.Cells(n, 7).Value, ";", "") & ","
End If
Next
If Len(emailx) < 2 Then '如果邮件地址是空,那就不发送本城市
bbb.Offset(0, colnew - 1).Value = "无邮件地址"
mg = mg & FN(m, 3) & Left(" ", 10 - Len(FN(m, 3)) * 2) & "无邮件地址" & Chr(13)
GoTo line5
End If
linkman = Left(linkman, Len(linkman) - 1) '删掉最后一个符号
emailx = Left(emailx, Len(emailx) - 1)
Set cm = CreateObject("CDO.Message") '创建对象
cm.From = UserName '设置发信人的邮箱
cm.To = emailx '设置收信人的邮箱
cm.Subject = FN(m, 1) '设定邮件的主题
cm.TextBody = "亲爱的 ********：" _
& Chr(10) & " 附件为 " & FN(m, 1) & "，请查收。" & Chr(10) & tex _
& Chr(10) & "谢谢！" _
& Chr(10) & " _______________________________________________________" _
& Chr(10) & " ** 部门 " _
& Chr(10) & " 姓名 " _
& Chr(10) & " 手机：********* " _
& Chr(10) & " 电话：********* " _
& Chr(10) & " Email：********* " _
& Chr(10) & " 地址：****************** " '邮件正文
cm.AddAttachment Pth & FN(m, 1) & "." & FN(m, 2) '添加附件
stUl = "http://schemas.microsoft.com/cdo/configuration/"
With cm.Configuration.Fields
.Item(stUl & "smtpserver") = "http://mail.qq.com" 'SMTP 服务器地址
.Item(stUl & "smtpserverport") = 25 'SMTP 服务器端口
.Item(stUl & "sendusing") = 2 '发送端口
.Item(stUl & "smtpauthenticate") = 1
.Item(stUl & "sendusername") = UserName '发送方邮箱名称
.Item(stUl & "sendpassword") = UserPass '发送方邮箱密码"
.Update
End With
cm.Send '发送
'生成反馈信息
If Err.Number = 0 Then
mg = mg & FN(m, 3) & Left(" ", 10 - Len(FN(m, 3)) * 2) & "发送成功" & Chr(13)
bbb.Offset(0, colnew - 1).Value = "发送成功"
Else
mg = mg & FN(m, 3) & Left(" ", 10 - Len(FN(m, 3)) * 2) & "发送失败" & Chr(13)
bbb.Offset(0, colnew - 1).Value = "发送失败"
End If
Set cm = Nothing '发送成功后即时释放对象
line5:
Next
MsgBox (Left(mg, Len(mg) - 1)) '确认结果
End Sub
再贴一个给职场小白
前面拆分，肯定有合并，再贴一个合并工作簿的代码，也超级简单的哦。
开始：
新建一个空白工作簿
还是一样右击 sheet——查看代码，这次不用建立模块，直接把代码贴进去即可
点击执行后，让你选择文件夹，你的先把要合并的所有工作簿放在一个文件夹内
数据是这样的
点击文件夹执行后
按确定后，数据就好了。
对了，工作簿名称不一样也不要紧哦
比如这样……
代码：
Sub 文件合并()
Application.ScreenUpdating = False
'On Error Resume Next
Dim Pth As String
Set wst1 = ActiveSheet
row1 = 0
wst1.Cells.Delete Shift:=xlUp
'打开文件夹
Dim shell, s
Set shell = CreateObject("Shell.Application")
Set fl = shell.BrowseForFolder(0, "请选择文件夹", 0, Pth)
If fl Is Nothing Then Exit Sub
Pth = fl.self.Path & "\"
'定义文件夹
Dim FS, F, FF, Fil, BName, EName
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.GetFolder(Pth)
Set FF = F.Files
For Each Fil In FF
BName = FS.GetBaseName(Fil)
EName = FS.GetExtensionName(Fil)
If EName = "xls" Or EName = "xlsx" Or EName = "XLS" Or EName = "XLSX" Then
Workbooks.Open (Fil)
Set wst2 = ActiveSheet
Set wb = ActiveWorkbook
strow = wst2.UsedRange.Rows.Count
If row1 = 0 Then
wst2.Rows("1:" & strow).Copy wst1.Cells(row1 + 1, 1)
row1 = row1 + strow
Else
wst2.Rows("2:" & strow).Copy wst1.Cells(row1 + 1, 1)
row1 = row1 + strow - 1
End If
Application.CutCopyMode = False
wb.Close (False)
End If
Next
MsgBox ("完成")
End Sub
拆分 or 合并 or 群发邮件，是三个独立的宏，都可以灵活运用。建议大家复制保存为 TXT 文档或者存到一个 Excel 里面，作为工具使用，不用每次黏贴复制了。
最后
1、我是女生
2、我早就从那家公司离职了，平时工作忙和妹子没再联系，走之前给她写了一堆程序，覆盖她工作中 50% 的 Excel 处理
3、只是同事之间的帮忙，而且我也喜欢研究。为什么要扯到感情，大家那么喜欢童话故事？
4、我不是专业写 VBA 的
花了两个小时一个一个截图 + 写注释，你能不能点个赞再走 n(*≧▽≦*)n