Excel VBA 简介及常用代码集锦——1
VBA，神一般的办公利器，在Excel可以随意操控全公司的打印机、Word、Powerpoint等等，自动完成各种任务以及数据更新和抓取，甚至可以实现报表或者报告的更新、汇总、发送一条龙，简直是居家旅游必备神器！
到底有多厉害呢，可以阅读何大大的文章，这篇文章也一直激励我去探索更多的Excel技能点。
此合集工具旨在提供常用代码块，让日常使用像调用函数一般容易，前人做过了无数的工作，我们只需要理解代码内容可以修改套用在自己的工作中即可，毕竟，效率第一嘛~
基本操作科普：
（1）打开宏编辑页面 Alt+F11；
（2）运行宏 F5 #复制完代码，按下F5就等结果好了
（3）逐行运行宏代码 F8 #调试代码很好用
（4）中断宏代码 Ctrl+Break #出现无脑无限循环时候很好用
（5）在宏编辑页面下，选中需要操作的工作薄，插入模块后粘贴代码
（6）录制宏是个极好的入门神奇
安利一波：推荐一下Excelhome出品的，由N多VBA大牛封装的，终身免费的Excel插件——易用宝！
因此，ExcelHome为广大Excel用户度身定做了一款Excel功能扩展工具软件，中文名为“Excel易用宝”，以提升Excel的操作效率为宗旨。针对Excel用户在数据处理与分析过程中的多项常用需求，Excel易用宝集成了数十个功能模块，从而让繁琐或难以实现的操作变得简单可行，甚至能够一键完成。
经过简单的安装操作后，Excel易用宝会显示在Excel功能区独立的选项卡上，如下图所示。
一、工作表处理：
- 一键生成带超链接的工作表目录
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 Sub2. 一键批量取消工作表隐藏
Sub qxyc()
Dim sht As Worksheet
'定义变量
For Each sht In Worksheets
'循环工作簿里的每一个工作表
sht.Visible = xlSheetVisible
'将工作表的状态设置为非隐藏
Next
End Sub3. 一键汇总各分表数据到总表
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 Sub4. 按指定名称批量建立工作表
'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 Sub5. 一键将总表数据拆分为多个分表
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 Sub6. 批量将工作表转为独立工作簿
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 Sub7. 按指定条件汇总各分表数据到总表
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