VBA常用功能代码

01.批量创建工作表

Sub NewSht()

    Dim shtActive As Worksheet, sht As Worksheet

    Dim i As Long, strShtName As String

    On Error Resume Next '当代码出错时继续运行

    Set shtActive = ActiveSheet

    For i = 2 To shtActive.Cells(Rows.Count, 1).End(xlUp).Row

        '单元格A1是标题，跳过，从第2行开始遍历工作表名称

        strShtName = shtActive.Cells(i, 1).Value

        '工作表名强制转换为字符串类型

        Set sht = Sheets(strShtName)   '当工作簿不存在工作表Sheets(strShtName)时，这句代码会出错，然后……

        If Err Then

            '如果代码出错，说明不存在工作表Sheets(t)，则新建工作表

            Worksheets.Add , Sheets(Sheets.Count)

            '新建一个工作表，位置放在所有已存在工作表的后面

            ActiveSheet.Name = strShtName '新建的工作表必然是活动工作表，为之命名 Err.Clear

            '清除错误状态

        End If

    Next

    shtActive.Activate '重新激活原工作表

End Sub

02.删除全部工作表

Sub DelShet() '删除所有工作表

    Dim sht As Worksheet

    Application.ScreenUpdating = False '关屏幕刷

    新Application.DisplayAlerts = False '关警告信息

    On Error Resume Next

    For Each sht In Worksheets

        sht.Delete '遍历工作表删除

    Next

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

End Sub

03.提取工作表名字

Sub GetShtByVba()

    Dim sht As Worksheet, k As Long

    Application.ScreenUpdating = False

    k = 1

    Range("a:b").Clear '清空数据Range("a:a").NumberFormat = "@" '设置文本格式

    For Each sht In Worksheets '遍历工作表取表名

        k = k + 1

        Cells(k, 1) = sht.Name

    Next

    Range("a1:b1") = Array("工作表名", "是否删除")

    Application.ScreenUpdating = True

End Sub

04.删除指定工作表

Sub DelShtByVba()

    Dim sht As Worksheet, i As Long, r

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    On Error Resume Next

    r = Range("a1").CurrentRegion '数据装入数组r

    For i = 2 To UBound(r) '遍历并删除工作表

        If r(i, 2) = "删除" Then Worksheets(CStr(r(i, 1))).Delete

    Next

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

End Sub

05.生成带超链接的工作表目录

Sub ml()

    Dim sht As Worksheet, i&, strShtName$

    Columns(1).ClearContents '清空A列数据Cells(1, 1) = "目录" '第一个单元格写入标题"目录" i = 1 '将i的初值设置为1.

    For Each sht In Worksheets '循环当前工作簿的每个工作表

        strShtName = sht.Name

        If strShtName <> ActiveSheet.Name Then

            '如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接

            i = i + 1 '累加工作表数量

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:="", SubAddress:="'" & strShtName & "'!a1", TextToDisplay:=strShtName

            '建超链接

        End If

    Next

End Sub

06.在各个分表创建返回总表的命令按钮

Dim strShtName As String

Sub Mybutton()

    Dim sht As Worksheet, btn As Button

    On Error Resume Next

    For Each sht In Worksheets

        With sht

            If .Name <> strShtName Then

                .Shapes(strShtName).Delete

                '删除原有的名称为shtn的按钮，避免重复创建

                Set btn = .Buttons.Add(0, 0, 60, 30) '使用add方法在工作表中添加一个按钮控件，add方法语法如下:表达式.Add(left,right,width,height)

                '新建按钮

                With btn

                    .Name = strShtName

                    '命令按钮命名

                    .Characters.Text = "返回总表" '按钮的文本内容

                    .OnAction = "LinkTable"

                    '指定按钮控件所执行的宏命令

                End With

            End If

        End With

    Next

    Set btn = Nothing

End Sub

Sub LinkTable()

    strShtName = "总表" '指定了返回总表的名字，可以根据实际需要修改为目标表的名称Worksheets(strShtName).Activate

    [a1].Select

End Sub

07批量取消工作表的隐藏

Sub unShtVisible()

    Dim sht As Worksheet

    For Each sht In Worksheets '遍历工作表，设置可见

        sht.Visible = xlSheetVisible

    Next

End Sub

08按指定名称批量创建工作簿

Sub CreateFiles()

    Dim strPath As String, strFileName As String

    Dim i As Long, r

    On Error Resume Next

    With Application.FileDialog(msoFileDialogFolderPicker)

        '用户选择文件夹路径

        If .Show Then strPath = .SelectedItems(1) Else Exit Sub

        '如果用户为选择文件夹则退出程序

    End With

    If Right(strPath, 1) <> "\" Then

        strPath = strPath & "\"

        Application.ScreenUpdating = False '取消屏幕刷新

        Application.DisplayAlerts = False '取消警告提示，当有重名工作簿时直接覆盖

        r = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row) '数据装入数组r

        For i = 2 To UBound(r) '标题不要，因此从第2个元素开始遍历数组r

            With Workbooks.Add '新建工作簿

                .SaveAs strPath & r(i, 1), xlWorkbookDefault

                '以指定名称、默认文件类型保存工作簿

                .Close True '关闭工作簿

            End With

        Next

        Application.ScreenUpdating = True

        Application.DisplayAlerts = True

        MsgBox "创建完成。"

    End Sub