VBA 工作表新建删除与排序

Excel VBA练习 2021-08-05

1554

今天有小伙伴给小编留言,按照不同列筛选打印,由于没看到数据源,搞得不是很明白,大致想了下,过几天试试做一个

这几天还是练习工作表的一些基本操作

示例文件下载

链接：https://pan.baidu.com/s/1S_Hs4m7OXiON2kTHhn1BCQ
提取码：abcd

关注公众号 ↓

新建工作表
在VBA中,如果需要新建工作表就需要用到Add方法

Worksheets.Add(Before,After,Count,Type)

Before:指定新建在当前工作表之前

After:指定新建在当前工作表之后

Count:指定新建工作表的数量,默认为1

Type:指定新建工作表的类型,默认普通工作表

按指定数据新建工作表

Sub Sht_Add() '新建工作表
    Dim Rng As Range, Cell As Range
    Dim ActSht As Worksheet
    Dim strErr$, strMsg$, strName$, s$
    On Error Resume Next
    Set Rng = 模块.SetRng("请选择需要删除工作表的数据来源")
    If Rng Is Nothing Then MsgBox "请重新选择!", 64, "提示!": Exit Sub
    Set Rng = Intersect(Rng, Rng.Parent.UsedRange) '获取实际数据来源的区域
    Set ActSht = ActiveSheet '当前工作表
    Call 模块.AppEx '调用自定义函数AppEx屏蔽错误弹窗更新公式更改手动计算
    For Each Cell In Rng
        strName = Cell.Value '工作表名称
        If Len(strName) Then
            With Sheets.Add(after:=Sheets(Sheets.Count))
                .Name = strName
            End With '新建工作表
            If Err Then '如果出错
                Err.Clear '清除错误
                ActiveSheet.Delete '无法命名,删除新建的表
                strErr = strErr & Chr(10) & strName '记录错误信息
            Else
                strMsg = strMsg & Chr(10) & strName '记录已删除工作表的信息
            End If
        Else
            strErr = strErr & Chr(10) & strName '记录删除失败的信息
        End If
    Next
    If strMsg <> "" Then s = "成功创建以下工作表:" & Chr(10) & Mid(strMsg, 2)
    If strErr <> "" Then s = s & Chr(10) & Chr(10) & "您为工作表或图标输入的名称无效。请确保:" & Chr(10) _
                            & "※名称不多于31个字符。" & Chr(10) _
                            & "※名称不包含下列任一字符:\/?*[或]。" & Chr(10) _
                            & "※名称不为空。" & Chr(10) _
                            & "创建失败名称如下 " & Chr(10) & Mid(strErr, 2)
    MsgBox s '播报信息
    ActSht.Select
    Call 模块.AppEx(True) '恢复系统设置
End Sub

如果工作表名输入无效会出现一下错误

删除工作表
其语法比较简单

WorkSheet.Delete

按指定数据删除工作表

Sub Sht_Del()'工作表删除
    Dim Rng As Range, Cell As Range
    Dim ActSht As Worksheet
    Dim strErr$, strMsg$, strName$, s$
    On Error Resume Next
    Set Rng = 模块.SetRng("请选择需要删除工作表的数据来源")
    If Rng Is Nothing Then MsgBox "请重新选择!", 64, "提示!": Exit Sub
    Set Rng = Intersect(Rng, Rng.Parent.UsedRange) '获取实际数据来源的区域
    Call 模块.AppEx '调用自定义函数AppEx屏蔽错误弹窗更新公式更改手动计算
    For Each Cell In Rng
        strName = Cell.Value '工作表名称
        If Len(strName) Then
            Worksheets(strName).Delete '删除工作表
            If Err Then '如果出错
                Err.Clear '清除错误
                strErr = strErr & Chr(10) & strName '记录错误信息
            Else
                strMsg = strMsg & Chr(10) & strName '记录已删除工作表的信息
            End If
        Else
            strErr = strErr & Chr(10) & strName '记录删除失败的信息
        End If
    Next
    If strMsg <> "" Then s = "成功删除以下工作表:" & Chr(10) & Mid(strMsg, 2)
    If strErr <> "" Then s = s & Chr(10) & Chr(10) & "以下工作表无法删除,确定是否存在该工作表??:" & Chr(10) & Mid(strErr, 2)
    MsgBox s '播报信息
    Call 模块.AppEx(True) '恢复系统设置
End Sub

工作表排序

原先,小编觉得这个没什么用,后来在做数据的时候发现还是比较有用的

例如我们从一个文件夹中导入一些工作表,在核对数据的时候会发现这些排列的顺序并不一致,这时候对工作表排序就起到作用了...

在此之间我们现将数据源整理下,按照工作表名称前的数字做升序排序

需要给工作表做排序就需要用到

WorkSheet.Move(Before,After)

只有两个参数任意选择一个,一个向前,一个向后

Sub Sht_Sort() '工作表排序
    Dim Sht As Worksheet, ActSht As Worksheet
    Dim Rng As Range, Cell As Range
    Dim strName$, strErr$, strMsg$, MaxSht&, s$
    On Error Resume Next
    Set Rng = 模块.SetRng("需要排序的工作表名称")
    If Rng Is Nothing Then MsgBox "请重新选择!", 64, "提示!": Exit Sub
    Set ActSht = ActiveSheet '当前工作表
    Call 模块.AppEx
    MaxSht = Sheets.Count '获取所有工作表的数量
    For Each Cell In Rng
        strName = Cell.Value '工作表名称
        If Len(strName) Then
            Set Sht = Worksheets(strName) '赋值给Sht
            If Err Then '如果吃错,证明名称不对或者没有该工作表
                Err.Clear '清除错误
                strErr = strErr & Chr(10) & strName
            Else
                Sht.Move after:=Sheets(MaxSht) '移动到最后一位,不停的移动,第一个位置及返回当前工作表右边
                strMsg = strMsg & Chr(10) & strName
            End If
        Else
            strErr = strErr & Chr(10) & strName '如果是空值,连接错误信息
        End If
    Next
    ActSht.Select
    If strErr <> "" Then s = "不存在以下工作表:" & Chr(10) & Mid(strErr, 2)
    If strMsg <> "" Then s = s & Chr(10) & "以下工作表排序完成:" & Chr(10) & Mid(strMsg, 2)
    MsgBox s '输出信息
    Call 模块.AppEx(True)
End Sub

我们不难发现,三个代码都差不多,今天文章较长,代码中小编都带有注释,这里就不在解析了

...

收工!我们明天见

如果小伙伴有好的思路,可以在小编的公众号留言发给小编研究下

文章觉得有用,点个赞+在看,你的每一次点赞和转发就是小编原创的动力

数据库

文章转载自Excel VBA练习，如果涉嫌侵权，请发送邮件至：contact@modb.pro进行举报，并提供相关证据，一经查实，墨天轮将立刻删除相关内容。

VBA 工作表新建删除与排序

评论