VBA学习(7)：按指定名单批量创建工作表

xwLink1996

已于 2024-06-18 09:54:33 修改

阅读量387

点赞数 14

分类专栏： VBA学习文章标签： VBA excel VSTO

于 2024-06-18 09:47:08 首次发布

本文链接：https://blog.csdn.net/nianfen/article/details/139763757

版权

VBA学习专栏收录该内容

57 篇文章 26 订阅

订阅专栏

如下图所示，需要按A列的名单，批量创建工作表。


Sub NewShtBySelection()
    Dim shtAct As Worksheet
    Dim rngData As Range, c As Range
    Dim strName As String
    Dim n As Long, y As Long, strErr As String
    If ActiveWorkbook.ProtectStructure = True Then
        MsgBox "工作簿有保护，无法新建工作表，请先撤除保护。"
        Exit Sub
    End If
    On Error Resume Next '忽略程序错误继续运行
    Set rngData = Application.InputBox("请选择新建工作表名称来源。", _
                                Title:="提示", _
                                Default:=Selection.Address, _
                                Type:=8) '用户选择名称来源区域
    Set rngData = Intersect(rngData, rngData.Parent.UsedRange)
     '交集运算，避免用户选择整列数据造成运算量虚大或选择区域空白
    If rngData Is Nothing Then '如果用户关闭了对话框，或选择区域空白，则退出程序
        MsgBox "未选择有效区域。"
        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 '如果工作表名称非空
            Err.Clear '清除错误
            Worksheets.Add 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

代码解析见注释，概要总结如下：

第6行至第9行代码判断工作簿是否有保护，如果工作簿有保护是无法创建工作表的，弹窗提示用户并退出程序。

第10行代码忽略程序错误继续运行。
第11行代码使用Application.InputBox语句使用户选择工作表名称的来源单元格区域。第15行代码交集获取有效数据区域。第17行代码判断用户是否点击了对话框的取消按钮或者选择了空白单元格区域。
第21行代码记录当前表，以便程序运行结束后，Excel界面回到当前位置。
第22至第27行代码取消屏幕刷新、公式重算等。
第28至第42行代码遍历名单区域。第32至第33行代码新建工作表并命名。

第34至第40行代码判断错误号，如果存在错误，说明工作表名称不符合Excel要求，包含斜杠等特殊符号，则删除新建的工作表，并记录错误名称。