VBA，神一般的办公利器，在Excel可以随意操控全公司的打印机、Word、Powerpoint等等，自动完成各种任务以及数据更新和抓取，甚至可以实现报表或者报告的更新、汇总、发送一条龙，简直是居家旅游必备神器！

此合集工具旨在提供常用代码块，让日常使用像调用函数一般容易，前人做过了无数的工作，我们只需要理解代码内容可以修改套用在自己的工作中即可，毕竟，效率第一嘛~

基本操作科普：
（1）打开宏编辑页面 Alt+F12；
（2）运行宏 F5 #复制完代码，按下F5就等结果好了
（3）逐行运行宏代码 F8 #调试代码很好用
（4）中断宏代码 Ctrl+Break #出现无脑无限循环时候很好用
（5）在宏编辑页面下，选中需要操作的工作薄，插入模块后粘贴代码
（6）录制宏是个极好的入门神奇

一、工作表处理：

1. 一键生成带超链接的工作表目录

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
           '累加i
           ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", SubAddress:="'" & strShtName & "'!a1", TextToDisplay:=strShtName
           '建超链接
        End If
    Next
End Sub

2. 一键批量取消工作表隐藏

Sub qxyc()
    Dim sht As Worksheet
    '定义变量
    For Each sht In Worksheets
    '循环工作簿里的每一个工作表
        sht.Visible = xlSheetVisible
        '将工作表的状态设置为非隐藏
    Next
End Sub

3. 一键汇总各分表数据到总表

Sub collect()

    'VBA编程学习与实践，一键多表数据汇总~看见星光

    Dim sht As Worksheet, rng As Range, k&, trow&

    Application.ScreenUpdating = False

    '取消屏幕更新，加快代码运行速度

    trow = Val(InputBox("请输入标题的行数", "提醒"))

    If trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub

    '取得用户输入的标题行数，如果为负数，退出程序

    Cells.ClearContents

    '清空当前表数据

    Cells.NumberFormat = "@"

    '设置文本格式

    For Each sht In Worksheets

    '遍历表格

        If sht.Name <> ActiveSheet.Name Then

        '如果表格名称不等于当前表名则进行复制数据……

            Set rng = sht.UsedRange

            '定义rng为表格已用区域

            k = k + 1

            '累计K值

            If k = 1 Then

            '如果是首个表格，则K为1，则把标题行一起复制到汇总表

                rng.Copy

                [a1].PasteSpecial Paste:=xlPasteValues

            Else

                '否则，扣除标题行后再复制黏贴到总表，只黏贴数值

                rng.Offset(trow).Copy

                Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues

            End If

        End If

    Next

    [a1].Activate

    '激活A1单元格

    Application.ScreenUpdating = True

    '恢复屏幕刷新

End Sub

4. 按指定名称批量建立工作表

'VBA根据A列数据批量建立工作表的代码如下：



Sub NewSht()
    'ExcelHome VBA编程实践与学习
    Dim Sht As Worksheet, Rng As Range
    Dim Sn, t$
    Set Rng = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
    '将工作表名称所在的单元格区域赋值给变量Rng，单元格A1是标题，不读入
    On Error Resume Next
    '当代码出错时继续运行
    For Each Sn In Rng
    '遍历Rng(工作表名称集合）
        t = Sn
        '还记得这里我们为什么用这句代码吗？
        Set Sht = Sheets(t)
        '当工作簿不存在工作表Sheets(t)时，这句代码会出错，然后……
        If Err Then
        '如果代码出错，说明不存在工作表Sheets(t)，则新建工作表
            Worksheets.Add , Sheets(Sheets.Count)
            '新建一个工作表，位置放在所有已存在工作表的后面
            ActiveSheet.Name = t
            '新建的工作表必然是活动工作表，为之命名
            Err.Clear
            '清除错误状态
        End If
    Next
    Rng.Parent.Activate
    '重新激活名称数据所在的工作表
End Sub

5. 一键将总表数据拆分为多个分表

Sub SplitShts()
    Dim d As Object, sht As Worksheet
    Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
    Dim rngData As Range, rngGist As Range
    Dim lngTitleCount&, lngGistCol&, lngColCount&
    Dim rngFormat As Range
    Dim strKey As String
    Set d = CreateObject("scripting.dictionary")
    Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
    '========用户选择的拆分依据列
    lngGistCol = rngGist.Column
    '========拆分依据列的列标
    lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？"))
    '========用户设置总表的标题行数
    If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub
    Set rngData = ActiveSheet.UsedRange
    '========总表的数据区域
    Set rngFormat = ActiveSheet.Cells
    '========总表的单元格集用于粘贴总表格式
    aData = rngData.Value
    lngGistCol = lngGistCol - rngData.Column + 1
    '========计算依据列在数组中的位置
    lngColCount = UBound(aData, 2)
    '========数据源的列数
    For i = lngTitleCount + 1 To UBound(aData)
        If aData(i, lngGistCol) = "" Then aData(i, lngGistCol) = "单元格空白"
        strKey = aData(i, lngGistCol)
    '========统一转换为字符串格式
        If Not d.exists(strKey) Then
    '========字典中不存在关键字时将行号装入字典
            d(strKey) = i
        Else
            d(strKey) = d(strKey) & "," & i
    '========如果字段存在关键字则合并行号
        End If
    Next
    Application.DisplayAlerts = False
    For Each sht In ActiveWorkbook.Worksheets
    '========删除字典中存在的表名
        If d.exists(sht.Name) Then sht.Delete
    Next
    Application.DisplayAlerts = True
    aKeys = d.keys
    '========字典的key集
    Application.ScreenUpdating = False
    For i = 0 To UBound(aKeys)
        If aKeys(i) <> "" Then
            aTemp = Split(d(aKeys(i)), ",")
    '========取出item里储存的行号
            ReDim aResult(1 To UBound(aTemp) + 1, 1 To lngColCount)
    '========声明放置结果的数组aResult
            k = 0
            For x = 0 To UBound(aTemp)
                k = k + 1
                For j = 1 To lngColCount
                    aResult(k, j) = aData(aTemp(x), j)
                Next
            Next
            With Worksheets.Add(, Sheets(Sheets.Count))
    '========新建一个工作表
                .Name = aKeys(i)
                .[a1].Resize(UBound(aData), lngColCount).NumberFormat = "@"
    '========设置单元格为文本格式
                If lngTitleCount > 0 Then .[a1].Resize(lngTitleCount, lngColCount) = aData
    '========标题行
                .[a1].Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
    '========数据
                rngFormat.Copy
                .[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    '========复制粘贴总表的格式
                .[a1].Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
    '========删除多余的格式单元格
                .[a1].Select
            End With
        End If
    Next
    rngData.Parent.Activate
    '========激活总表
    Application.ScreenUpdating = True
    Set d = Nothing
    Set rngData = Nothing
    Set rngGist = Nothing
    Set rngFormat = Nothing
    Erase aData: Erase aResult
    MsgBox "数据拆分完成！"
End Sub

6. 批量将工作表转为独立工作簿

Sub Newbooks()

    'EH技术论坛。VBA编程学习与实践。看见星光

    Dim sht As Worksheet, mypath$

    With Application.FileDialog(msoFileDialogFolderPicker)

   '选择保存工作薄的文件路径

        .AllowMultiSelect = False

        '不允许多选

        If .Show Then

            mypath = .SelectedItems(1)

            '读取选择的文件路径

        Else

            Exit Sub

            '如果没有选择保存路径，则退出程序

        End If

    End With

    If Right(mypath, 1) <> "\" Then mypath = mypath & "\"

    Application.DisplayAlerts = False

    '取消显示系统警告和消息，避免重名工作簿无法保存。当有重名工作簿时，会直接覆盖保存。

    Application.ScreenUpdating = False

    '取消屏幕刷新

    For Each sht In Worksheets

    '遍历工作表

        sht.Copy

        '复制工作表，工作表单纯复制后，会成为活动工作薄

        With ActiveWorkbook

            .SaveAs mypath & sht.Name, xlWorkbookDefault

            '保存活动工作薄到指定路径下，以默认文件格式

            .Close True '关闭工作薄并保存

        End With

    Next

    MsgBox "处理完成。", , "提醒"

    Application.ScreenUpdating = True '恢复屏幕刷新

    Application.DisplayAlerts = True '恢复显示系统警告和消息

End Sub

7. 按指定条件汇总各分表数据到总表

Sub CollectSheets()
    'ExcelHome VBA编程学习与实践
    Dim sht As Worksheet, rng As Range, k&, trow&,temp
    Application.ScreenUpdating = False
    '取消屏幕更新，加快代码运行速度
    temp = InputBox("请输入需要合并的工作表所包含的关键词：", "提醒")
    If StrPtr(temp) = 0 Then Exit Sub
    '如果点击了inputbox的取消或者关闭按钮，则退出程序
    trow = Val(InputBox("请输入标题的行数", "提醒"))
    If trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
    '取得用户输入的标题行数，如果为负数，退出程序
    Cells.ClearContents
    '清空当前表数据
    For Each sht In Worksheets
    '循环读取表格
        If sht.Name <> ActiveSheet.Name Then
        '如果表格名称不等于当前表名则……
            If InStr(1, sht.Name, temp, vbTextCompare) Then
           '如果表中包含关键词则进行汇总动作(不区分关键词字母大小写）
                Set rng = sht.UsedRange
                '定义rng为表格已用区域
                k = k + 1
                '累计K值
                If k = 1 Then
                '如果是首个表格，则K为1，则把标题行一起复制到汇总表
                    rng.Copy
                    [a1].PasteSpecial Paste:=xlPasteValues
                Else
                    '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
                    rng.Offset(trow).Copy
                    Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
                End If
            End If
        End If
    Next
    [a1].Activate
    '激活A1单元格
    Application.ScreenUpdating = True
    '恢复屏幕刷新
End Sub