VBA学习(9)：按指定名单一键删除工作表

今天继续给大家聊VBA编程中工作表对象的常用操作，主要内容是如何批量删除工作表；也就是删除单个工作表、删除全部工作表和删除指定名单内的工作表。

1.删除单个工作表

删除工作表需要使用到工作表对象的delete方法，语法格式如下：

工作表对象.delete

举个例子，以下代码可以删除当前工作簿的首个工作表。

Sub DelSht()
    Application.DisplayAlerts = False
    Worksheets(1).Delete
    Application.DisplayAlerts = True
End Sub

删除工作表的动作，会引发系统会弹出一个消息框

第2行代码的作用就是屏蔽此类系统显示的警告和消息，避免程序运行被打断

第4行代码恢复系统显示警告消息的功能。

2.删除全部工作表

以下代码可以删除当前工作簿"全部"的工作表

Sub DelShtAll()
    Dim sht As Worksheet
    Application.DisplayAlerts = False
    For Each sht In Sheets '集合遍历
        If sht.Name <> ActiveSheet.Name Then
            sht.Delete '如果sht的名字不等于当前工作表则删除
        End If
    Next
    Application.DisplayAlerts = True
End Sub

代码采用集合遍历的方式遍历当前工作簿每一张工作表，如果该工作表不是当前工作表则删除。代码运行后，工作簿就只剩下当前工作表孤零零一个人了。

打个响指，需要说明两点，一个是系统要求工作簿必须存在至少一张可见工作表，因此我们并不能将全部工作表都解雇，上述代码选择了保留当前工作表

另外，删除这个动作是无视工作表是否隐藏的，即便工作表隐藏不可见，也一样会被删掉

3.删除指定名单工作表

如下图所示，需要根据A2:B9单元格区域所提供的名单将相关工作表全部删除。

示例代码如下：

Sub DelShtByCustom()
    Dim sht As Worksheet, rngData As Range, c As Range
    Dim d As Object, y As Long
    Dim strName As String, strErr As String
    If ActiveWorkbook.ProtectStructure = True Then
        MsgBox "工作簿有保护，需要先撤销保护再运行代码"
        Exit Sub
    End If
    On Error Resume Next '使程序忽略错误继续运行
    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 d = CreateObject("scripting.dictionary") '后期字典
    For Each sht In Sheets '遍历工作表名存入字典
        strName = sht.Name
        d(strName) = ""
    Next
    With Application '取消屏幕刷新、信息警告等
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    For Each c In rngData '遍历名单区域
        strName = c.Value
        If Len(strName) Then '如果名字非空
            If d.exists(strName) Then '如果字典中存在删除表名
                If Sheets.Count > 1 Then '判断工作表个数是否可删
                    Sheets(strName).Delete '删除工作表
                    y = y + 1 '累加个数
                Else
                    MsgBox "系统要求工作表必须保留至少一张，因此" & _
                            strName & "未能删除。"
                End If
            Else '如果不存在删除表名
                strErr = strErr & "," & strName '合并不存在的表名
            End If
        End If
    Next
    With Application '恢复屏幕刷新、信息警告等
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
    If strErr <> "" Then
        MsgBox "以下名称工作簿中不存在工作表，未能删除：" & vbCrLf _
            & Mid(strErr, 2)
    Else
        MsgBox "处理完成。"
    End If
    Set d = Nothing
End Sub

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

第5至第8行代码判断工作簿是否有保护，工作簿结构保护状态下，工作表是不被允许开除的，违法行为知道吧？

第9行代码使程序忽视错误继续运行。

第10至第18行代码使用Application.InputBox语句允许户选择删除名单的区域，并判断该区域是否有效。

第19至第23行代码将当前工作簿现有工作表的名字存入字典。

第24至第28行代码取消屏幕刷新、警告消息框、公式重算等。

第29至第44行代码遍历名单数据，第32行代码判断字典中是否存在需要删除的表名，如果存在，则删除，否则使用变量strErr记录未能删除的名单。

第45至第49行代码恢复屏幕刷新、警告消息框、公式重算等。

第50至第55行代码使用Msgbox语句显示处理结果相关信息。

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