VBA学习(8)：按指定模板批量创建工作表

今天给大家分享一下如何按指定名单和模板批量创建工作表。

首先，当前工作簿内需要存在一张名为"模板"的工作表；该工作表的格式和数据可以根据个人需要自定义。

然后在另外一张工作表提供需要创建新工作表的名单。

最后，复制运行以下代码即可。

Sub NewShtByTemp()
    Dim shtAct As Worksheet, shtTemp As Worksheet
    Dim rngData As Range, strName As String, c As Range
    Dim n As Long, y As Long, strErr As String
    On Error Resume Next
    If ActiveWorkbook.ProtectStructure = True Then
        MsgBox "工作簿有保护，无法新建工作表，请先撤除保护。"
        Exit Sub
    End If
    Set rngData = Application.InputBox("请选择新建工作表名称来源。", _
                                Title:="公众号Excel星球", _
                                Default:=Selection.Address, _
                                Type:=8) '用户选择名称来源区域
    Set rngData = Intersect(rngData, rngData.Parent.UsedRange)
     '交集运算，避免用户选择整列数据造成运算量虚大或选择区域空白
    If rngData Is Nothing Then '如果用户关闭了对话框，或选择区域空白，则退出程序
        MsgBox "未选择有效区域。"
        Exit Sub
    End If
    Set shtTemp = Worksheets("模板")
    If Err.Number Then
        MsgBox "HI，没找到名为模板的工作表，请核实。"
        Exit Sub
    End If
    Set shtAct = ActiveSheet '当前工作表，操作完成后界面回到这里
    With Application '取消系统刷新、警告、链接、公式重算等
        .ScreenUpdating = False
        .DisplayAlerts = False
        .AskToUpdateLinks = False
        .Calculation = xlCalculationManual
    End With
    For Each c In rngData '遍历名单
        strName = c.Value '工作表名称
        If Len(strName) Then '如果工作表名称非空
            Sheets(strName).Delete '删除可能存在的旧表
            Err.Clear '清除错误记录
            shtTemp.Copy after:=Sheets(Sheets.Count) '复制一个模板表
            ActiveSheet.Name = strName '命名
            If Err.Number Then '如果存在错误，说明有重名或工作表名称不规范
                ActiveSheet.Delete '删除已新建工作表
                n = n + 1 '记录问题名称数量
                strErr = strErr & "," & strName '记录名称
            Else
                y = y + 1 '记录正确创建工作表的数量
            End If
        End If
    Next
    shtAct.Select
    With Application '恢复系统设定
        .ScreenUpdating = True
        .DisplayAlerts = True
        .AskToUpdateLinks = True
        .Calculation = xlCalculationAutomatic
    End With
    If n Then
        MsgBox "有" & n & "张工作表创建失败，原因是工作表重名或格式错误。" & _
                "名单如下：" & vbCrLf & _
                Mid(strErr, 2)
    ElseIf y Then
        MsgBox "创建完成。"
    End If
End Sub

本段代码和按名单批量创建工作表的代码十分相似，只是增加了模板部分，详细解析见注释，概要总结如下：
第20至第24行代码采用试错的方式，判断当前工作簿是否有名为"模板"的工作表，如无，则弹窗提醒用户，并退出程序。
第32至第47行代码遍历新建工作表名单。
第35行代码删除可能重名的旧工作表。第37行代码复制模板表，并放置在当前所有工作表之后。

技术交流，软件开发，欢迎加微信xwlink1996 

---

作者其他作品：

VBA实战(Excel)(1)：提升运行速度

Ribbon第一节：控件大全

HTML实战(1)：新建一个HTML

VB.net实战(VSTO)：Excel插件的安装与卸载