VBA常用小代码

01 工作表

按选择的名单在当前工作簿批量创建或删除工作表

  用Excel_VBA，按指定的名单，可以批量创建工作簿、工作表、Word文档等等。

  它的整个运行过程的逻辑也很简单，关键是几个错误处理的过程预先规避。

  • 1、选择单元格区域为空时怎么处理？
  • 2、当单元格内容格式不对，不能作为工作表时怎么处理？

批量删除工作表的过程和创建的过程几乎一致，只是循环中的处理过程不同，一个是.add的方法，一个是.delete的方法，这里用一个示例中的两段代码来演示。

如图所示，按照工作表的名单，在当前工作簿中批量创建(删除)工作表：
点击放大的图片

运行视频：

源码下载：

描述：

  根据指定名单批量创建或删除工作表

VBA实现过程：
  • 1.On Error Resume Next，因为有错误发生时的预处理，添加它是为了保证程序发生错误不中断；
  • 2.Worksheets.Add after:=Sheets(Sheets.Count)，新建工作表，位置在最后一个；
  • 3.ActiveSheet.Name = Str_name，创建后对新创建的工作表命名；
  • 4.在批量删除的过程中，只是在循环中增加一个对工作表的循环，把工作表名称不属于名单的工作表、又包含在需要删除的名单中的工作表,.delete删除即可；
  • 5.两段代码关键的不同，在'------------的夹行中。
示例代码（批量创建）
复制成功!
1

Sub 工作表名单批量创建工作表()
    If ActiveWorkbook.ProtectStructure = True Then         '只能在解除工作簿保护的状态下，创建工作表，如有，先解除
        MsgBox "工作簿有保护，无法新建工作表，请先撤除保护。"
        Exit Sub
    End If

    Dim Name_list, rng As Range
    Dim Str_name, Str_Errname, Act_name As String
    Dim n As Integer

    On Error Resume Next                                '在错误发生时，仍可以继续运行
    Set Name_list = Application.InputBox("选择工作表名单", "提示_", Type:=8)          '选择工作表名单
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub                              '未选择时退出
    If WorksheetFunction.CountA(Name_list) = 0 Then MsgBox "选择的内容为空": Exit Sub '选择的单元格区域内容都是空时也退出

    Act_name = Name_list.Parent.Name                   '获取选择的单元格区域所在的工作表名，最后要激活它

    ' 禁用屏幕更新和警告
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


    For Each rng In Name_list                           '遍历名单
        Str_name = rng.Value                            '单元格内容赋值作为工作表名称
        If Len(Str_name) Then                           '如果名称非空
            Err.Clear
            Worksheets.Add after:=Sheets(Sheets.Count)  '新建工作表，位置在当最后一个
            ActiveSheet.Name = Str_name                 '重命名

            If Err.Number Then                          '如果发生了错误，说明工作表名称不规范（包含空格、\斜杠等)
                ActiveSheet.Delete
                n = n + 1
                Str_Errname = Str_Errname & "," & Str_name '记录不规范的名称，最终告知
            End If
        End If
    Next rng
    Sheets(Act_name).Activate                            '激活名单所在在工作表

    ' 恢复屏幕更新和警告
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    If n > 0 Then
        MsgBox "有" & n & "张工作表创建失败，原因是工作表重名或格式错误。" & _
        "名单有：" & vbCrLf & Str_Errname
    End If

    MsgBox "完成"  '过程结束告知！

End Sub
示例代码（批量删除）
复制成功!
1

Sub 工作表名单批量删除工作表()
    If ActiveWorkbook.ProtectStructure = True Then         '只能在解除工作簿保护的状态下，创建工作表，如有，先解除
        MsgBox "工作簿有保护，无法新建工作表，请先撤除保护。"
        Exit Sub
    End If

    Dim Name_list, rng As Range
    Dim Str_name, Act_name As String
    Dim sht As Worksheet

    Set Name_list = Application.InputBox("选择工作表名单", "提示_", Type:=8)          '选择工作表名单
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub                              '未选择时退出
    If WorksheetFunction.CountA(Name_list) = 0 Then MsgBox "选择的内容为空": Exit Sub '选择的单元格区域内容都是空时也退出

    Act_name = Name_list.Parent.Name                   '获取选择的单元格区域所在的工作表名，最后要激活它

    ' 禁用屏幕更新和警告
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next                                '在错误发生时，仍可以继续运行
    For Each rng In Name_list                           '遍历名单
        Str_name = rng.Value                            '单元格内容
    '---------------------------------------------------------------------------
        For Each sht In Sheets
            If Str_name = sht.Name And sht.Name <> Act_name Then
                sht.Delete                                               '如果工作表的名字没有在选择需要删除的名单中存在，且不是名单所在的工作表，就删除它
            End If
        Next sht
    '---------------------------------------------------------------------------
    Next rng
    Sheets(Act_name).Activate                            '激活名单所在在工作表


    ' 恢复屏幕更新和警告
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


    MsgBox "完成"  '过程结束告知！

End Sub
请开发者喝杯咖啡 请开发者喝杯咖啡！