金桔
金币
威望
贡献
回帖0
精华
在线时间 小时
|
两年后的更新，时隔两年，我联合我的VBA老师推出了VBA课程，哈哈！欢迎大家关注！
POINT小数点数据：小数点Excel-VBA课程正式上线——————————————————
更新：建议下载文件，链接：http://pan.baidu.com/s/1dERLTPR 密码：0h3q
————————————————————
看到这个话题，我决定送给职场新人一个福利~~
我刚毕业那会，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 & &#34;:&#34; & rowx).AutoFilter Field:=colx, Criteria1:=&#34;<>&#34; & Itm, Operator:=xlAnd &#39;筛选列,筛选值为不符合当前省份
Sht.Range(Sht.Cells(rowx + 1, colx), Sht.Cells(StRow, colx)).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp &#39;删除被筛选出来的行(删掉不为当前省份的行)
Sht.Range(rowx & &#34;:&#34; & rowx).AutoFilter &#39;取消筛选
ActiveWindow.SmallScroll Down:=-StRow
ActiveWindow.SmallScroll ToRight:=-100
If Dir(Wb1.Path & &#34;\拆分\&#34;, vbDirectory) = &#34;&#34; Then MkDir ThisWorkbook.Path & &#34;\拆分\&#34; &#39;看看当前文件夹内是否存在&#34;拆分&#34;文件夹,如果没有就创建一个
Pth = Wb1.Path & &#34;\拆分\&#34; & Itm & &#34;-&#34; & namex & &#34;.xls&#34;
Wb2.SaveAs Filename:=Pth, FileFormat:=xlExcel8, Password:=&#34;&#34;, WriteResPassword:=&#34;&#34;, ReadOnlyRecommended:=False, CreateBackup:=False
Wb2.Close &#39;关闭表格
Next
Set Pro = Nothing &#39;释放变量
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 &#39;打开屏幕更新
Application.DisplayAlerts = True &#39;打开提示事件
End Sub
Sub 通用发送邮件()
&#39;On Error Resume Next
Dim cm As Variant
UserForm1.Show
UserName = UserForm1.ComboBox1
UserPass = UserForm1.TextBox1.Value
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & &#34;\&#34;
If .Show = -1 Then
Pth = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems.Item(1) & &#34;\&#34;
End If
End With
&#39;定义文件夹
Dim FS, F, FF, Fil, BName, EName
Set FS = CreateObject(&#34;Scripting.FileSystemObject&#34;)
Set F = FS.GetFolder(Pth)
Set FF = F.Files
If FF Is Nothing Or F Is Nothing Then
MsgBox (&#34;文件或文件夹错误,请查证在本文件目录内存在&#39;拆分&#39;文件夹,并且已经生成拆分文件&#34;)
Exit Sub
End If
&#39;保存文件信息
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), &#34;-&#34;) - 1)
Next
Set Sht = ThisWorkbook.Sheets(&#34;邮件联系人&#34;)
colnew = Sht.Cells(1, Columns.Count).End(xlToLeft).Column + 1 &#39;联系人空白列(用于记录发送结果)
Sht.Cells(1, colnew).Value = Pth & Chr(10) & Date & &#34; &#34; & Time & &#34; 发送结果&#34;
tex = InputBox(&#34;请输入邮件正文自定义段&#34;)
For m = 1 To i
Err.Clear
linkman = &#34;&#34;
emailx = &#34;&#34;
Set bbb = Sht.Range(&#34;a:a&#34;).Find(FN(m, 3))
If bbb Is Nothing Then
rownew = Sht.Range(&#34;a60000&#34;).End(xlUp).Row + 1
Sht.Cells(rownew, 1).Value = FN(m, 3)
Sht.Cells(rownew, colnew).Value = &#34;未找到发件人&#34;
mg = mg & FN(m, 3) & Left(&#34; &#34;, 10 - Len(FN(m, 3)) * 2) & &#34;未找到发件人&#34; & Chr(13)
GoTo line5
End If
For n = 1 To Sht.Range(&#34;a60000&#34;).End(xlUp).Row &#39;循环查找联系人姓名和邮件地址
If FN(m, 3) = Sht.Cells(n, 1).Value Then
linkman = linkman & Sht.Cells(n, 2).Value & &#34;、&#34;
emailx = emailx & Replace(Sht.Cells(n, 7).Value, &#34;;&#34;, &#34;&#34;) & &#34;,&#34;
End If
Next
If Len(emailx) < 2 Then &#39;如果邮件地址是空,那就不发送本城市
bbb.Offset(0, colnew - 1).Value = &#34;无邮件地址&#34;
mg = mg & FN(m, 3) & Left(&#34; &#34;, 10 - Len(FN(m, 3)) * 2) & &#34;无邮件地址&#34; & Chr(13)
GoTo line5
End If
linkman = Left(linkman, Len(linkman) - 1) &#39;删掉最后一个符号
emailx = Left(emailx, Len(emailx) - 1)
Set cm = CreateObject(&#34;CDO.Message&#34;) &#39;创建对象
cm.From = UserName &#39;设置发信人的邮箱
cm.To = emailx &#39;设置收信人的邮箱
cm.Subject = FN(m, 1) &#39;设定邮件的主题
cm.TextBody = &#34;亲爱的********：&#34; _
& Chr(10) & &#34; 附件为 &#34; & FN(m, 1) & &#34;，请查收。&#34; & Chr(10) & tex _
& Chr(10) & &#34;谢谢！&#34; _
& Chr(10) & &#34; _______________________________________________________&#34; _
& Chr(10) & &#34; **部门 &#34; _
& Chr(10) & &#34; 姓名 &#34; _
& Chr(10) & &#34; 手机：********* &#34; _
& Chr(10) & &#34; 电话：********* &#34; _
& Chr(10) & &#34; Email：********* &#34; _
& Chr(10) & &#34; 地址：****************** &#34; &#39;邮件正文
cm.AddAttachment Pth & FN(m, 1) & &#34;.&#34; & FN(m, 2) &#39;添加附件
stUl = &#34;http://schemas.microsoft.com/cdo/configuration/&#34;
With cm.Configuration.Fields
.Item(stUl & &#34;smtpserver&#34;) = &#34;http://mail.qq.com&#34; &#39;SMTP服务器地址
.Item(stUl & &#34;smtpserverport&#34;) = 25 &#39;SMTP服务器端口
.Item(stUl & &#34;sendusing&#34;) = 2 &#39;发送端口
.Item(stUl & &#34;smtpauthenticate&#34;) = 1
.Item(stUl & &#34;sendusername&#34;) = UserName &#39;发送方邮箱名称
.Item(stUl & &#34;sendpassword&#34;) = UserPass &#39;发送方邮箱密码&#34;
.Update
End With
cm.Send &#39;发送
&#39;生成反馈信息
If Err.Number = 0 Then
mg = mg & FN(m, 3) & Left(&#34; &#34;, 10 - Len(FN(m, 3)) * 2) & &#34;发送成功&#34; & Chr(13)
bbb.Offset(0, colnew - 1).Value = &#34;发送成功&#34;
Else
mg = mg & FN(m, 3) & Left(&#34; &#34;, 10 - Len(FN(m, 3)) * 2) & &#34;发送失败&#34; & Chr(13)
bbb.Offset(0, colnew - 1).Value = &#34;发送失败&#34;
End If
Set cm = Nothing &#39;发送成功后即时释放对象
line5:
Next
MsgBox (Left(mg, Len(mg) - 1)) &#39;确认结果
End Sub
——————————————————————————————————
谢谢大家的赞，那我就再贴一个给职场小白
前面拆分，肯定有合并，再贴一个合并工作簿的代码，也超级简单的哦。
开始：
新建一个空白工作簿
还是一样右击sheet——查看代码，这次不用建立模块，直接把代码贴进去即可
点击执行后，让你选择文件夹，你的先把要合并的所有工作簿放在一个文件夹内
数据是这样的
点击文件夹执行后
按确定后，数据就好了。
对了，工作簿名称不一样也不要紧哦
比如这样....
代码：
Sub 文件合并()
Application.ScreenUpdating = False
&#39;On Error Resume Next
Dim Pth As String
Set wst1 = ActiveSheet
row1 = 0
wst1.Cells.Delete Shift:=xlUp
&#39;打开文件夹
Dim shell, s
Set shell = CreateObject(&#34;Shell.Application&#34;)
Set fl = shell.BrowseForFolder(0, &#34;请选择文件夹&#34;, 0, Pth)
If fl Is Nothing Then Exit Sub
Pth = fl.self.Path & &#34;\&#34;
&#39;定义文件夹
Dim FS, F, FF, Fil, BName, EName
Set FS = CreateObject(&#34;Scripting.FileSystemObject&#34;)
Set F = FS.GetFolder(Pth)
Set FF = F.Files
For Each Fil In FF
BName = FS.GetBaseName(Fil)
EName = FS.GetExtensionName(Fil)
If EName = &#34;xls&#34; Or EName = &#34;xlsx&#34; Or EName = &#34;XLS&#34; Or EName = &#34;XLSX&#34; Then
Workbooks.Open (Fil)
Set wst2 = ActiveSheet
Set wb = ActiveWorkbook
strow = wst2.UsedRange.Rows.Count
If row1 = 0 Then
wst2.Rows(&#34;1:&#34; & strow).Copy wst1.Cells(row1 + 1, 1)
row1 = row1 + strow
Else
wst2.Rows(&#34;2:&#34; & strow).Copy wst1.Cells(row1 + 1, 1)
row1 = row1 + strow - 1
End If
Application.CutCopyMode = False
wb.Close (False)
End If
Next
MsgBox (&#34;完成&#34;)
End Sub
——————————————————————————————————————
拆分or合并or群发邮件，是三个独立的宏，都可以灵活运用。建议大家复制保存为TXT文档或者存到一个excel里面，作为工具使用，不用每次黏贴复制了。
最后
1、我是女生
2、我早就从那家公司离职了，平时工作忙和妹子没再联系，走之前给她写了一堆程序，覆盖她工作中50%的excel处理
3、只是同事之间的帮忙，而且我也喜欢研究。为什么要扯到感情，大家那么喜欢童话故事？
4、我不是专业写VBA的
花了两个小时一个一个截图+写注释，你能不能点个赞再走n(*≧▽≦*)n |
|
/3 
浙公网安备33010802005999号 
2025庆【网站十二周
2024庆中秋、迎国庆
2024庆【网站十一周
2023庆【网站十周年
2022庆【网站九周年
2021庆中秋、迎国庆
雷达卡
发表于 2025-5-10 17:57
提升卡
发表于 2025-5-10 17:58
