日报标题：职场新人的福利，学好了，要做一小时的表格几分钟就搞定 知乎用户，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 阅读原文
