如何按指定名称和模板批量创建Excel工作簿？

每天一篇Excel技术图文

微信公众号：Excel星球

NO.1060-模版创建工作簿

作者：看见星光

 微博：EXCELers / 知识星球：Excel

HI，大家好，我是星光。

上一期给大家分享了如何按指定名单批量创建工作簿，这期再给大家分享下如何按指定名单和模板批量创建工作簿。

如上图所示，有一张工作表提供了新建工作簿的名单，又有一个工作表名为'模板'，作为新建工作簿的模板。则运行以下代码即可按指定名单和模板批量创建工作簿。

代码看不全可以左右移动..▼

Sub NewWbByTemp() Dim rngData As Range, c As Range Dim strName As String, strPath As String Dim n As Long, y As Long, strErr As String Dim shtTemp As Worksheet On Error Resume Next '忽略程序错误继续运行 Set rngData = getRngData() '用户选择名单区域 If Err.Number Then Exit Sub '如果选择无效区域则退出程序 Set shtTemp = Worksheets('模板') If Err.Number Then MsgBox 'HI，没找到名为模板的工作簿，请核实。' Exit Sub End If Call disAppSet '取消屏幕刷新等系统设置 strPath = ThisWorkbook.Path '当前工作簿的路径为新建工作簿保存路径 If Right(strPath, 1) <> '\' Then strPath = strPath & '\' For Each c In rngData '遍历名单 strName = c.Value '工作簿名称 If Len(strName) Then '如果工作簿名称非空 Err.Clear '清除错误 shtTemp.Copy '复制工作表，不指定位置参数，会成为活动工作簿 ActiveWorkbook.SaveAs strPath & strName '保存工作簿 If Err.Number Then '如果存在错误，说明工作簿名称不规范 n = n + 1 '记录问题名称数量 strErr = strErr & ',' & strName '记录名称 Else y = y + 1 '记录正确创建工作簿的数量 End If ActiveWorkbook.Close , False End If Next Call reAppSet If n Then MsgBox '有' & n & '张工作簿创建失败，原因是工作簿重名或格式错误。' & _ '名单如下：' & vbCrLf & _ Mid(strErr, 2) ElseIf y Then MsgBox '创建完成。' End IfEnd Sub
Sub disAppSet() With Application '取消屏幕刷新、信息警告、公式重算等 .ScreenUpdating = False .DisplayAlerts = False .AskToUpdateLinks = False .Calculation = xlCalculationManual End WithEnd Sub
Sub reAppSet() With Application '取消屏幕刷新、信息警告、公式重算等 .ScreenUpdating = True .DisplayAlerts = True .AskToUpdateLinks = True .Calculation = xlCalculationAutomatic End WithEnd Sub
'用户选择名称来源区域Function getRngData() As Range Dim rngData As Range Set rngData = Application.InputBox('请选择新建工作簿名称来源。', _ Title:='提示', _ Default:=Selection.Address, _ Type:=8) '用户选择名称来源区域 Set rngData = Intersect(rngData, rngData.Parent.UsedRange) '交集运算，避免用户选择整列数据造成运算量虚大或选择区域空白 If rngData Is Nothing Then '如果用户关闭了对话框，或选择区域空白，则退出程序 MsgBox '未选择有效区域。' Exit Function End If Set getRngData = rngDataEnd Function

代码详细解释见注释……

打个响指，坦白的说，这段代码和上一期代码十分相似，简直是同父异母的哥俩好。第9行至第13行代码，指定名称为'模板'的工作表为新建工作簿的模板；如果当前工作簿查无此表，则退出程序。

第21行代码使用工作表的Copy方法复制一个工作表，但未指定复制后工作表的保存位置；我们上一章讲过，这种情况下，系统会将该工作表转换为活动工作簿。

第22行代码将活动工作簿保存到指定路径下。第23至28行代码判断工作簿名称是否符合规则。其余代码和上一节代码并无二样，也就不需赘言。

……

就酱，打完收工，有疑问Excel会员答疑群中聊，下期再见。

示例文件下载，百度网盘▼
https://pan.baidu.com/s/1WBE8zrLDN6ziOKrIxvzckw

加入我的Excel会员，全面学习Excel

透视表 函数 图表 VBA PQ想学啥学啥