VBA常用小代码合集，总有一个是您用得上的~ (qq.com)
如何在各个分表创建返回总表的命令按钮？
今天再来给大家聊一下如何使用VBA代码，只需一键，即可在各个分表生成返回总表的按钮。
示例代码如下：
Sub Mybutton()
Dim sht As Worksheet, btn As Button, strShtName As String
On Error Resume Next
strShtName = "总表"
For Each sht In Worksheets
If sht.Name <> strShtName Then
sht.Shapes(strShtName).Delete '删除原有的名称为shtn的按钮，避免重复创建
Set btn = sht.Buttons.Add(0, 0, 60, 30) '新建按钮，释义见小贴士
With btn
.Name = strShtName '命令按钮命名
.Characters.Text = "返回总表" '按钮的文本内容
.OnAction = "LinkTable" '指定按钮控件所执行的宏命令
End With
End If
Next
Set btn = Nothing
End Sub
'_________________________________________
Sub LinkTable()
Dim trShtName As String
strShtName = "总表" '设置变量strShtName为总表的名称，可以根据实际总表的名称做修改
Worksheets(strShtName).Activate
[a1].Select
End Sub代码解析：
1，变量strShtName指定了返回总表的名字，可以根据实际需要修改为目标表的名称，比如"目录"。
strShtName = "总表"2，第10行代码使用add方法在工作表中添加一个按钮控件，add方法语法如下：
表达式.Add(left,right,width,height)
表达式是必须的，是一个表单控件集合。例如按钮是buttons,标签是labels，列表框listboxes，复选框checkboxes等。
left和right也是必须的，表示该控件相对于工作表的A1单元格左上角的初始坐标。本例中为0，0。意思也就是以A1单元格为左上角。
width和height还是必须的，表示该控件初始化的宽度和高度。
三个方法，批量取消工作表隐藏。
有朋友询问如何批量取消工作表隐藏？今天咱们就来聊下这个问题。
咱们这说的是批量取消工作表隐藏，不是批量隐藏工作表。后者所有Excel的版本都是支持的，选中多个工作表后，右键菜单选择隐藏就可以了。
至于批量取消隐藏，大部分Excel版本都不支持，除了MS365以外。
❶ MS365版本
如果你使用的版本是MS365，可以右键点击工作表标签→取消隐藏。打开取消隐藏对话框后，按住Ctrl键选取多个工作表标签，就可以一次性取消隐藏了。
悄悄说一下，WPS也支持批量取消工作表隐藏，【取消隐藏】对话框还支持全选快捷键Ctrl+A。
❷ 普通Excel版本
如果你所使用的Excel不是氪金的MS365，怎么办呢？
首先，在工作表未隐藏状态下，在【视图】选项卡中依次单击【自定义视图】→【添加】，打开添加视图对话框，在名称栏输入一个名字，比如"看见星光"，并【确定】。
这样一来，我们就建了一个名称为"看见星光"的自定义视图。
弄这个有啥用呢？打个响指，马上揭晓。
将需要隐藏的工作表批量隐藏。此时，如果需要批量取消隐藏工作表，在视图选项卡下，依次单击【自定义视图】→【看见星光】→【显示】就可以了┓( ´∀` )┏
💡小思考：
如何快速切换回批量工作表隐藏的状态呢？
❸ VBA代码
偏方虽好，但是药三分毒局限性很大，就再给大家提供一种VBA的方式。
以下代码可以一次性取消全部工作表的隐藏状态。
Sub unShtVisible()
Dim sht As Worksheet
For Each sht In Worksheets '遍历工作表，设置可见
sht.Visible = xlSheetVisible
Next
End Sub如果只需要取消隐藏部分工作表，可以在代码中添加条件判断语句，将需要隐藏的工作表名称写在以下代码的第3行中，并以"/"作为分隔符合并即可。
Sub unShtVisible()
Dim sht As Worksheet, t
t = "看见星光/Excel星球/Sheet5/" '将需要隐藏的工作表名称写在这
For Each sht In Worksheets '遍历工作表，设置可见
If InStr(t, sht.Name &"/") Then
sht.Visible = xlSheetVisible
End If
Next
End SubVBA：如何批量修改工作表名称？
本章给大家分享的内容是使用VBA代码对工作表批量重命名。举个例子，如下图所示，一个工作簿里包含了多张工作表，现在需要在每张工作表名称前增加一个前缀词"星光"。
操作步骤如下▼
首先使用以下代码将工作表的名称罗列在当前表的A列；相关代码我们在如何遍历工作表中分享过了，不知道你是否还记得：
Sub GetShName()
Dim sht As Worksheet, k As Long
Application.ScreenUpdating = False
With Range("a:a")
.Clear '清除所有
.NumberFormat = "@" '设置文本格式
End With
k = 1
Cells(1, 1) = "目录"
For Each sht In Sheets '遍历工作表
k = k + 1 '累加个数
Cells(k, 1) = sht.Name
Next
Application.ScreenUpdating = True
End Sub示例文件中代码返回结果如下：
然后在B列对A列的表名添加新名字，可以根据具体的规则，使用不同的函数进行处理。本例的规则比较简单，B列输入以下公式即可。
="星光-"&A2
最后使用以下代码按照A:B列的数据对工作表批量重命名。
Sub NewShName()
Dim aData, aRes, i As Long
If ActiveWorkbook.ProtectStructure = True Then
MsgBox "工作簿有保护，工作表无法重命名。"
Exit Sub
End If
Application.ScreenUpdating = False
On Error Resume Next '忽略错误，继续运行
aData = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim aRes(1 To UBound(aData), 1 To 1)
For i = 1 To UBound(aData)
Err.Clear '错误状态清除
If aData(i, 2) <> "" Then
Sheets(aData(i, 1)).Name = aData(i, 2)
If Err.Number Then '如果有错
aRes(i, 1) = "更名失败"
Else
aRes(i, 1) = "成功"
End If
Else
aRes(i, 1) = "空白值"
End If
Next
Range("c1").Resize(UBound(aRes), 1) = aRes
Application.ScreenUpdating = True
MsgBox "更名完成，结果参考C列。"
End Sub代码详细解析见注释，概要解释如下：
第9行代码将A:B列的数据存入数组aData。第10行代码重新定义aRes数组的大小，aRes数组的作用是存放工作表重命名成功与否的信息。
第11至第23行代码遍历数组aData，借助工作表的Name属性对工作表重命名。代码使用试错法判断工作表重命名成功与否，并将执行结果写入数组aRes。
第24行代码将aRes的数据写入当前工作表的C列
VBA：如何对工作表按名称按自定义规则排序？
说起排序这个词，想必大家都不陌生，这是数据处理过程中最常见的操作之一，但我们今天聊的不是数据排序，而是如何对工作表排序。
我举个例子，如下图所示，一张工作簿有N张工作表，现在需要按升序对其重新排序。
操作步骤如下：
首先使用以下代码将工作表的名称罗列在当前表的A列
Sub GetShName()
Dim sht As Worksheet, k As Long
Application.ScreenUpdating = False
With Range("a:a")
.Clear '清除所有
.NumberFormat = "@" '设置文本格式
End With
k = 1
Cells(1, 1) = "目录"
For Each sht In Sheets '遍历工作表
k = k + 1 '累加个数
Cells(k, 1) = sht.Name
Next
Application.ScreenUpdating = True
End Sub示例文件中代码返回结果如下：
然后对A列数据进行排序，这个时候你可以用各种手段修理它们，升序、降序、自定义排序、基操、函数等等，你爱怎么着就怎么着，开心就好。
(#^.^#)
最后使用以下代码按照A列排序后的数据对工作表重新排放位置。
Sub SortSh()
Dim sht As Worksheet, shtAct As Worksheet
Dim aData, i As Long, intCount As Long
Dim strName As String, strErr As String
On Error Resume Next '忽略程序错误继续运行
If ActiveWorkbook.ProtectStructure = True Then
MsgBox "工作簿有保护，工作表无法排序。"
Exit Sub
End If
Application.ScreenUpdating = False
aData = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
intCount = Sheets.Count '所有工作表的数量
Set shtAct = ActiveSheet '当前工作表
For i = 1 To UBound(aData) '遍历名单
strName = aData(i, 1) '工作表名称
Err.Clear '错误状态初始化
Set sht = Sheets(strName)
If Err.Number Then '试错法判断工作簿是否存在相关工作表
strErr = strErr & "," & strName
Else
'移动到最后一个工作表之后
sht.Move after:=Sheets(intCount)
End If
Next
If strErr <> "" Then
MsgBox "以下工作表名称工作簿中不存在" & vbCr _
& Mid(strErr, 2)
Else
MsgBox "排序完成。"
End If
shtAct.Select '回到操作表
Application.ScreenUpdating = True
End Sub代码详细解析见注释，概要解释如下▼
第11行代码将A列的数据存入数组aData。
第14至第24行代码遍历数组。依次将相关工作表名移动到最后一张工作表之后——听说每个人都有一个梦想，做一名人民教师，为的不是教书育人，而是点名扔粉笔头。代码运行的场景大概就是这样：你化身人民教师，先将工作表排成一排，让他们按身高或亲疏依次站到排尾，也就实现有序排列…
第18行代码使用试错法判断当前工作簿是否存在相关工作表名称，该方法我们在如何遍历工作表中也详细解释过了
批量工作表加密
以下代码可以为当前工作簿的工作表批量加密。
Sub ProtectSht()
Dim strAds As String, sht As Worksheet
Dim strKey As String, strTemp As String
Dim rng As Range, strMsg As String
Dim strNoShtName As String, strYesShtName As String
On Error Resume Next
strAds = InputBox("请输入单元格保存范围，例如A1:B10." & vbCr _
& "可以设置不连续单元格，中间请以逗号分隔。比如A1:B10,D2:D8" & vbCr _
& "如果需要全表保护，可以直接确定。", Default:="全表保护")
If StrPtr(strAds) = False Then Exit Sub
If strAds = "全表保护" Then strAds = Cells.Address
Set rng = Range(strAds) '测试输入的单元格区域是否有效
If Err Then MsgBox "你输入的单元格区域地址不是正确的格式，请重新操作。": Exit Sub
strKey = InputBox("请输入保护密码。") '第一次输入密码
If StrPtr(strKey) = False Then Exit Sub
strTemp = InputBox("请再次输入保护密码。") '第二次输入密码
If StrPtr(strKey) = False Then Exit Sub
If strKey <> strTemp Then MsgBox "你两次输入的密码不一致，系统退出，请重新操作。": Exit Sub
For Each sht In Worksheets '遍历工作表加密保护
With sht
If .ProtectContents = False Then '如果工作表未保护
.Cells.Locked = False '全部单元格区域取消锁定
.Range(strAds).Locked = True '需要保护的区域锁定
.Protect strKey, True, True, True '保护工作表，只允许编辑非锁定区域
strYesShtName = strYesShtName & "," & .Name '保护成功的工作表名称
Else
strNoShtName = strNoShtName & "," & .Name '自身已有保护功能的工作表
End If
End With
Next
If strYesShtName <> "" Then strMsg = "工作表：" & Mid(strYesShtName, 2) & "的" & strAds & "区域保护完成"
If strNoShtName <> "" Then strMsg = strMsg & vbCrLf & "以下工作表自身已有保护，无法再次保护：" & Mid(strNoShtName, 2)
MsgBox (strMsg)
End Sub代码解析见注释。
小贴士：
▶ 代码运行后，会弹出一个对话框，允许用户设置每张工作表需要保护的单元格区域，不连续的单元格区域，彼此之间请使用分隔符逗号。该选项默认为全表保护模式。
▶ 之后会弹出对话框，要求用户输入两次保护密码。
▶ 代码运行完成后，会告知用户保护了哪些工作表，哪些工作表自身已处于保护状态，无法再次保护。
一个模版，汇总分表成总表
举个例子，如下图所示。一个工作簿包含了多张工作表，每张工作表的标题名称可能不一样，但排列顺序是相同的，另外数据区域可能包含合并单元格……
代码运行效果如图所示..▼
复制运行以下代码可以将多表数据汇总，并自由选择是否保留源表的合并单元格格式等。
Sub GetShData()
Dim sht As Worksheet, rngData As Range
Dim i As Long, intLastRow As Long
Dim intTitCount, intYesOrNo As String
Dim rngLast As Range, rngFirst As Range
intTitCount = getTitCount() '获取用户输入的标题行数
If intTitCount = False Then Exit Sub
intYesOrNo = MsgBox("是否需要保留源表格式、公式等？", vbYesNo)
Call disAppSet '取消屏幕刷新，公式重算等
Cells.Clear '清空当前表数据
For Each sht In Worksheets '遍历工作表
If sht.Name <> ActiveSheet.Name Then
Set rngData = sht.UsedRange '有效单元格区域
If IsEmpty(rngData) = False Then '判断工作表是否非空
If sht.AutoFilterMode = True Then
sht.Cells.AutoFilter '取消筛选，避免数据复制遗漏
End If
k = k + 1 '计数器
If k = 1 Then '如果是第一张工作表
rngData.Copy '复制源表单元格
Range("b1").PasteSpecial xlPasteColumnWidths '粘贴列宽
Call rngPaste(Range("b1"), intYesOrNo) '粘贴数据
Set rngFirst = Cells(1, 1) '开始单元格
intLastRow = GetIntLastRow '结束行
Set rngLast = Cells(intLastRow, 1) '结束单元格
Range(rngFirst, rngLast) = sht.Name '填充工作表名称
Else
rngData.Offset(intTitCount).Copy '扣除标题复制
Call rngPaste(Cells(rngLast.Row + 1, 2), intYesOrNo)
intLastRow = GetIntLastRow
Set rngFirst = rngLast.Offset(1) '开始单元格
Set rngLast = Cells(intLastRow, 1) '结束单元格
Range(rngFirst, rngLast) = sht.Name '填充工作表名称
End If
End If
End If
Next
Call rngFormat(intTitCount)
Call reAppSet '恢复屏幕刷新等
MsgBox "一共汇总了" & k & "张工作表。"
End Sub
'获取用户输入的标题行数
Function getTitCount()
Dim intTitCount
intTitCount = InputBox("请输入标题行的行数", _
Title:="公众号Excel星球", _
Default:=1)
If StrPtr(intTitCount) = False Then
getTitCount = False
Exit Function
End If
If IsNumeric(intTitCount) = False Then
MsgBox "标题行的行数只能输入数字。"
getTitCount = False
Exit Function
End If
If intTitCount < 0 Then
MsgBox "标题行数不能为负数。"
getTitCount = False
Exit Function
End If
getTitCount = intTitCount
End Function
'取消屏幕刷新，公式重算等
Sub disAppSet()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
'恢复屏幕刷新等
Sub reAppSet()
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
'最后存在数据的行
Function GetIntLastRow()
GetIntLastRow = Cells.Find("*", _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End Function
'粘贴子过程
'两个参数
'一个粘贴区域起始单元格
'一个粘贴的方式，是否只粘贴数值
Sub rngPaste(ByVal rng As Range, ByVal intYesOrNo As Long)
If intYesOrNo = 6 Then '是否保留源表格式
rng.PasteSpecial xlPasteAll '粘贴全部
Else
rng.PasteSpecial xlPasteValues '粘贴数值
End If
'Application.CutCopyMode = False
End Sub
'将B列格式复制到A列
Sub rngFormat(ByVal intTitCount As Long)
Range("b:b").Copy
With Range("a1")
.PasteSpecial xlPasteFormats '粘贴B列格式
.Value = "工作表名" '填写工作表来源
.Resize(intTitCount, 1).Merge '合并多行标题
.HorizontalAlignment = xlCenter '水平居中
.VerticalAlignment = xlCenter '垂直居中
.EntireColumn.AutoFit '自动列宽
.Select
End With
End Sub第6行代码调用getTitCount函数过程获取用户在InputBox对话框中输入的标题行行数。
第8行代码使用Msgbox函数允许用户选择是否保留分表单元格的格式、函数公式等数据。如果用户选择了【是】则保留，选择了【否】则只保留源表单元格的值属性。
第9行代码调用disAppSet过程取消屏幕刷新、公式重算、警告信息等。
第11行至第37行代码遍历工作表汇总数据。
第15至第17行代码取消工作表筛选，避免复制数据缺失。
第19行至第34行代码复制分表区域粘贴到总表，并使用变量k累计汇总的工作表数量。如果是首个单元格，则直接复制到当前工作表的A1单元格，否则扣除掉标题行后再粘贴到当前工作表存在数据的最后一行。
第38行代码调用rngFormat过程为A列添加单元格格式。
第39行代码调用reAppSet过程恢复系统屏幕刷新、公式重算、警告信息等功能。
如何按字段名称批量合并多个分表成总表？
之前给大家分享过一期VBA小代码，作用是按字段顺序快速将多个分表的数据汇总成一张总表，并保留分表的函数公式、单元格格式等数据。不过在实际工作中，各个分表的字段数量，甚至排列顺序可能并不相同，这时候就需要按字段名称合并多分表的数据。
举个例子，如下图所示的工作簿，包含了多张工作表，每张工作表的字段数量和顺序都不尽相同。
示例代码如下：
Sub GetShDataByTit()
Dim d As Object, aData, aRes
Dim i As Long, j As Long, k As Long
Dim strKey As String, strShtName As String, n As Long
Dim sht As Worksheet, rngData As Range, shtAct As Worksheet
Dim intLastRow As Long, y As Long
Set d = CreateObject("scripting.dictionary")
Set shtAct = ActiveSheet
On Error Resume Next
Call disAppSet
Cells.Clear '清空当前表
Cells.NumberFormat = "@" '设置文本格式，避免文本数值变形
Cells(1, 1) = "工作表名称" 'A列放工作表名称
k = 1 '计数器初始化
For Each sht In Worksheets '遍历工作表
strShtName = sht.Name '工作表名称
If strShtName <> ActiveSheet.Name Then
If sht.FilterMode = True Then sht.Cells.AutoFilter '取消筛选
Set rngData = sht.UsedRange '已使用单元格区域
If IsEmpty(rngData) = False Then '如果工作表非空表
intLastRow = GetIntLastRow(sht) '最后存在数据的行
Set rngData = Intersect(rngData, sht.Rows("1:" & intLastRow))
aData = rngData.Value
If IsArray(aData) Then '判断数据源是否为数组
n = n + 1 '累加汇总的工作表个数
ReDim aRes(1 To UBound(aData), 1 To k) '定义结果数组大小
For j = 1 To UBound(aData, 2) '遍历列
strKey = aData(1, j) '字段名
If Not d.exists(strKey) Then
k = k + 1 '累加不同字段的个数
If k > UBound(aRes, 2) Then '重新调整结果数组大小
ReDim Preserve aRes(1 To UBound(aRes), 1 To k)
End If
d(strKey) = k '定义字段名在结果数组中的位置
For i = 1 To UBound(aData) '如果前8行有日期则整列设置日期格式
If i > 8 Then Exit For
If IsDate(aData(i, j)) Then
shtAct.Cells(i, j + 1). _
EntireColumn.NumberFormat = "yyyy-m-d"
Exit For
End If
Next
End If
y = d(strKey) '字段在结果数组中的列位置
For i = 2 To UBound(aData) '遍历行
aRes(i - 1, y) = aData(i, j) '存入结果数组
Next
Next
For i = 2 To UBound(aData) 'A列作为工作表来源字段
aRes(i - 1, 1) = strShtName '填写工作表名称
Next
End If
intLastRow = GetIntLastRow(shtAct) + 1 '最后存在数据的行
Cells(intLastRow, 1).Resize(UBound(aRes), UBound(aRes, 2)) = aRes
End If
End If
Next
shtAct.Range("b1").Resize(1, k - 1) = d.keys '标题行数据
Call reAppSet '恢复屏幕刷新等
Set d = Nothing '释放字典
If Err.Number Then
MsgBox Err.Description
Else
MsgBox "一共汇总了" & n & "张工作表。"
End If
End Sub
'取消屏幕刷新，公式重算等
Sub disAppSet()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
'恢复屏幕刷新等
Sub reAppSet()
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
'最后存在数据的行
Function GetIntLastRow(ByVal sht As Worksheet)
GetIntLastRow = sht.Cells.Find("*", _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End Function代码详细解释见注释，概要说明如下▼
第10行代码调用disAppSet过程取消屏幕刷新、公式重算等系统设置。
第11行代码清空当前工作表。
第12行代码将整表设置为文本格式，避免纯文本数值，比如"00123"，汇总后变形。
第15至56行代码遍历工作表，汇总数据。
第18行代码取消可能存在的工作表筛选。
第20行代码判断工作表是否为空表，并将已使用的单元格区域赋值变量rngData。
第21至第22行代码调整rngData的大小，规避UsedRange可能虚大的问题，这个问题我们在什么是单元格对象里解释过了，不知你是否还记得？
第24行代码判断aData是否为数组，如果工作表只有一个单元格存在值，则变体变量aData并非数组，也就在事实上丧失了汇总的意义。
第26行代码定义一个结果数组aRes。
第27至42行代码借助字典，统计不同名字字段的个数，并定位字段名在结果数组中的列序，因此字段名为Key，不同字段的个数累加值为Item。
第35至第43行代码判断每个字段前8行是否为日期类型的数据，如果条件成立，则将汇总表的单元格格式设置为日期类型，避免数据汇总后日期值变形。
第44至46行代码遍历行，将记录存入结果数组的相关行列。
第49至第51行代码将工作表名称存入结果数组的第1列。
第53至第54行代码将结果数组写入汇总表。
第58行代码将标题数据写入汇总表。
第59行代码调用reAppSet子过程，恢复屏幕刷新、公式重算等系统设置。
第61至65行代码返回程序运行结果的信息。
按任意字段将总表拆分为多个分表
今天再给大家分享一段代码，作用是按任意列，将总表数据拆分为多个分表。
如下图所示的数据为例，是一张总表，标题行存在合并单元格等特殊情况，现在需要按任意字段，比如C列的班级字段，拆分为多张分表。
复制运行以下代码即可▼
Sub SplitShByArr()
Dim shtAct As Worksheet, sht As Worksheet
Dim rngData As Range, rngGistC As Range, rngTemp As Range
Dim d As Object, aData, aKeys, vnt
Dim intTitCount, strKey As String, strName As String
Dim strADS As String, rngTit As Range
Dim i As Long, j As Long, intFirstR As Long, intLastR As Long
Dim k As Long, x As Long, intActR As Long
Dim intFirstC As Long, intGistC As Long
'On Error Resume Next '忽略错误继续运行程序
'
'获取用户输入的标题行数▼
intTitCount = getTitCount()
If intTitCount = False Then Exit Sub
'
'获取拆分依据列▼
Set rngGistC = GetRngGistC()
If Err.Number Then GoTo errDescript
'
Call disAppSet '取消屏幕刷新等系统设置
'
Set shtAct = ActiveSheet '当前工作表
If shtAct.FilterMode = True Then shtAct.Cells.AutoFilter '取消筛选状态
Set rngData = shtAct.UsedRange '实际区域
aData = rngData.Value '总表数据存入数组aData
intFirstC = rngData.Column '实际区域开始列
intGistC = rngGistC.Column - intFirstC + 1 '依据列在aData中的序列
intFirstR = rngData.Row '实际区域开始行
intActR = intTitCount - intFirstR + 2 '扣除标题的数组开始行
intLastR = GetintLastR(shtAct) '实际区域结束行
With shtAct
Set rngTit = .Range(.Cells(1, 1), _
.Cells(intTitCount, _
UBound(aData, 2) + intFirstC - 1)) '标题区域
End With
'
'参数数组，修正异常数据▼
Set d = CreateObject("scripting.dictionary") '后期字典
ReDim aRef(1 To intLastR) '数组aRef，修正拆分列特殊数据
For i = intActR To UBound(aData)
If i > intLastR Then Exit For '如果大于有效数据最大行则退出循环
vnt = aData(i, intGistC)
If IsError(vnt) Then
aRef(i) = "错误值"
ElseIf vnt = "" Then
aRef(i) = "空白单元格"
ElseIf IsDate(vnt) Then '避免日期斜杠格式无法创建工作表
aRef(i) = Format(vnt, "yyyy-m-d")
Else
aRef(i) = vnt
End If
strKey = aRef(i)
d(strKey) = d(strKey) + 1 '记录不同拆分关键字的数量
Next
'
'通过前8行数据来判断该列是否为特殊的文本数值
For j = 1 To UBound(aData, 2) '遍历列
For i = intActR To UBound(aData) '遍历前8行
If i > 8 Then Exit For
vnt = aData(i, j)
If IsNumeric(vnt) Then '是否数值
If VarType(aData(i, j)) = 8 Then '是否文本
strADS = strADS & "," & Cells(1, j + intFirstC - 1).Address
Exit For
End If
End If
Next
Next
strADS = Mid(strADS, 2) '需要设置文本格式的单元格地址
'
aKeys = d.keys '字典Keys，拆分关键字数组
For i = 0 To UBound(aKeys) '遍历关键字
strName = aKeys(i) '关键字
ReDim aRes(1 To d(strName), 1 To UBound(aData, 2)) '结果数组
k = 0 '计数器归0
'
'筛选符合条件的记录存入结果数组
For x = 1 To UBound(aRef)
If aRef(x) = strName Then '如果关键字符合
k = k + 1 '累加符合条件的行
For j = 1 To UBound(aData, 2) '遍历列
aRes(k, j) = aData(x, j) '数据存入结果数组
Next
End If
Next
'
'建立新工作表，存放结果数组
DelSht (strName) '删除重名工作表
With Worksheets.Add(after:=Sheets(Sheets.Count)) '新建工作表
.Name = strName '命名
If Err.Number Then '如果名称有特殊字符，则退出程序
.Delete
GoTo errDescript
End If
If Len(strADS) Then
.Range(strADS).EntireColumn.NumberFormat = "@" '特殊列设置为文本格式
End If
With .Cells(intTitCount + 1, intFirstC).Resize(k, UBound(aRes, 2))
.Value = aRes '结果数组数据写入工作表
End With
.UsedRange.Borders.LineStyle = 1 '设置边框线
rngTit.Copy
.Range("a1").PasteSpecial xlPasteColumnWidths '粘贴列宽
.Range("a1").PasteSpecial xlPasteAll '粘贴标题
End With
Next
errDescript:
shtAct.Select
Call reAppSet '恢复屏幕刷新等系统设置
Set d = Nothing '释放字典内存
If Err.Number Then
MsgBox Err.Description
Else
MsgBox "拆分完成。"
End If
End Sub
'获取用户输入的标题行数
Function getTitCount()
Dim intTitCount
intTitCount = InputBox("请输入标题行的行数", _
Title:="公众号Excel星球", _
Default:=1)
If StrPtr(intTitCount) = False Then
getTitCount = False
Exit Function
End If
If IsNumeric(intTitCount) = False Then
MsgBox "标题行的行数只能输入数字。"
getTitCount = False
Exit Function
End If
If intTitCount < 0 Then
MsgBox "标题行数不能为负数。"
getTitCount = False
Exit Function
End If
getTitCount = intTitCount
End Function
'用户选择拆分依据列
Function GetRngGistC() As Range
Dim rngGistC As Range
Set rngGistC = Application.InputBox("请选择拆分依据列。", _
Title:="公众号Excel星球", _
Default:=Selection.Address, _
Type:=8)
If rngGistC Is Nothing Then
Exit Function
End If
If rngGistC.Columns.Count > 1 Then
MsgBox "拆分依据列只能是单列。"
Exit Function
End If
Set GetRngGistC = rngGistC
End Function
'取消屏幕刷新，公式重算等
Sub disAppSet()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
'恢复屏幕刷新等
Sub reAppSet()
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
'删除重名工作表
Function DelSht(ByVal strName As String)
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name = strName Then
sht.Delete
Exit Function
End If
Next
End Function
'最大数据有效行
Function GetintLastR(ByVal sht As Worksheet)
GetintLastR = sht.Cells.Find("*", _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End Function代码详细解释见注释，概要说明如下：
第13至第14行代码调用getTitCount函数过程，获取用户在InputBox对话框中输入的标题行行数。
第17至第18行代码调用GetRngGistC函数过程，获取用户在Application.inputbox对话框中选择的拆分依据列。
第20行代码调用disAppSet过程，取消屏幕刷新等系统设置。
第22至第23行代码将总表数据存入数组aData，并获取获取总表实际存在数据的区域、首列、拆分依据列在实际区域中的第几列、首行和尾行等重要数据。这是由于首行首列未必是第一行第一列，比如本例所示的数据，也就导致拆分依据列的列标未必是实际处理数据的列标。
第31至第35行代码计算标题区域，并赋值变量rngTit。
第38行至第54行代码遍历拆分依据列，处理异常值，比如空格、错误值和可能以"/"为格式的日期值。
第13至第14行代码调用getTitCount函数过程，获取用户在InputBox对话框中输入的标题行行数。
第57至第69行代码通过前8行数据判断相关列是否为文本格式，避免文本型数值，比如身份证，在拆分后变形。代码将文本型数值所在的单元格地址赋值变量strADS。
第70至第106行代码按关键字拆分总表数据。其中第78至第85行代码遍历数据源将符合条件的数据存入数组aRes。第86至105行代码新建工作表，并将结果数组的数据写入该工作表，并设置标题行。
第111至第115行代码使用MsgBox函数以消息框的形式显示数据拆分结果信息。
……
工作表事件示例：输入数据后锁定单元格
在工作表单元格中输入数据后，该单元格就被锁定，不能再编辑。
打开VBE，在工程资源管理器中双击该工作表名称打开其代码模块，在其中输入下面的代码：
'假设整个工作表的Locked=False
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rCell As Range
Dim ans As VbMsgBoxResult
For Each rCell In Target
With rCell
If Len(.Value) > 0 Then
ans = MsgBox("输入正确吗?" & vbCrLf & vbCrLf & _
vbTab & .Value & " (" & .Address(False, False) & ")" & vbCrLf & vbCrLf & _
"输入数值后将不能编辑这个单元格.", vbYesNo, "单元格锁定通知")
If ans = vbYes Then
If Me.ProtectContents Then
Me.Unprotect Password:="123" '首先撤销保护
.Locked = True
Me.Protect
Password:="123"
Else
.ClearContents
ActiveCell.Offset(-1, 0).Select '重新选择数据输入单元格
End If
End If
End With
Next rCell
End Sub这里，假设锁定工作表的密码为“123”。
可以使用右击单元格的方式，来重置想要重新输入数据的单元格。在该工作表代码模块中添加下面的代码：
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim rCell As Range
Dim ans As VbMsgBoxResult
For Each rCell In Target.Cells
With rCell
If Len(.Value) > 0 Then
ans = MsgBox("你想要重置这个单元格吗?" & vbCrLf & vbCrLf & _
vbTab & .Value & " (" & .Address(False, False) & ")", vbYesNo, "单元格锁定通知")
If ans = vbYes Then
If ActiveSheet.ProtectContents Then ActiveSheet.Unprotect Password:="123" '首先撤销保护
Application.EnableEvents = False
.ClearContents
.Locked = False
Application.EnableEvents = True
ActiveSheet.Protect Password:="123"
End If
End If
End With
Next
Cancel = True
End Sub这样，右击想要重新输入数据的单元格，会弹出一个消息框，询问你是否要重置这个单元格，如果点击“是”，则会清空该单元格并供输入新数据。
效果如下图1所示。
一键将工作表批量转换为独立的工作簿
将工作表批量转换为独立的工作簿，并保存到指定文件夹下？
举个例子，如下图所示▼
坦白的说，代码三五行，工作不用忙断肠，方法当然是有的。
看个效果动画：
运行以下VBA代码即可实现工作表转工作簿的操作。
Sub EachShtToWorkbook()
Dim sht As Worksheet, strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
'选择保存工作薄的文件路径
If .Show Then strPath = .SelectedItems(1) Else Exit Sub
'读取选择的文件路径,如果用户未选取路径则退出程序
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.DisplayAlerts = False
'取消显示系统警告和消息，避免重名工作簿无法保存。当有重名工作簿时，会直接覆盖保存。
Application.ScreenUpdating = False '取消屏幕刷新
For Each sht In Worksheets '遍历工作表
sht.Copy '复制工作表，工作表单纯复制后，会成为活动工作薄
With ActiveWorkbook
.SaveAs strPath & sht.Name, xlWorkbookDefault
'保存活动工作薄到指定路径下，以当前系统默认文件格式
.Close True '关闭工作薄并保存
End With
Next
MsgBox "处理完成。", , "提醒"
Application.ScreenUpdating = True '恢复屏幕刷新
Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub
将总表按任意列拆分为多个工作簿
如下图所示，是一张总表，现在需要按任意列，比如班级列吧，将它拆分为多个工作簿。
动画演示如下：
VBA代码如下（复制即可使用）
Sub SplitShByArr()
Dim shtAct As Worksheet, sht As Worksheet, wb As Workbook
Dim rngData As Range, rngGistC As Range, rngTemp As Range
Dim d As Object, aData, aKeys, vnt
Dim intTitCount, strKey As String, strName As String
Dim strADS As String, rngTit As Range
Dim i As Long, j As Long, intFirstR As Long, intLastR As Long
Dim k As Long, x As Long, intActR As Long
Dim intFirstC As Long, intGistC As Long
Dim strPath As String
On Error Resume Next '忽略错误继续运行程序
'
strPath = getStrPath() '用户选择文件保存路径
If strPath = "" Then Exit Sub
'
'获取用户输入的标题行数▼
intTitCount = getTitCount()
If intTitCount = False Then Exit Sub
'
'获取拆分依据列▼
Set rngGistC = GetRngGistC()
If Err.Number Then GoTo errDescript
'
Call disAppSet '取消屏幕刷新等系统设置
'
Set shtAct = ActiveSheet '当前工作表
If shtAct.FilterMode = True Then shtAct.Cells.AutoFilter '取消筛选状态
Set rngData = shtAct.UsedRange '实际区域
aData = rngData.Value '总表数据存入数组aData
intFirstC = rngData.Column '实际区域开始列
intGistC = rngGistC.Column - intFirstC + 1 '依据列在aData中的序列
intFirstR = rngData.Row '实际区域开始行
intActR = intTitCount - intFirstR + 2 '扣除标题的数组开始行
intLastR = GetintLastR(shtAct) '实际区域结束行
With shtAct '标题区域
Set rngTit = .Range(.Cells(1, 1), _
.Cells(intTitCount, _
UBound(aData, 2) + intFirstC - 1))
End With
'
'参数数组，修正异常数据▼
Set d = CreateObject("scripting.dictionary") '后期字典
ReDim aRef(1 To intLastR) '数组aRef，修正拆分列特殊数据
For i = intActR To UBound(aData)
If i > intLastR Then Exit For '如果大于有效数据最大行则退出循环
vnt = aData(i, intGistC)
If IsError(vnt) Then
aRef(i) = "错误值"
ElseIf vnt = "" Then
aRef(i) = "空白单元格"
ElseIf IsDate(vnt) Then '避免日期斜杠格式无法创建工作簿/表
aRef(i) = Format(vnt, "yyyy-m-d")
Else
aRef(i) = vnt
End If
strKey = aRef(i)
d(strKey) = d(strKey) + 1 '记录不同拆分关键字的数量
Next
'
'通过前8行数据来判断该列是否为特殊的文本数值
For j = 1 To UBound(aData, 2) '遍历列
For i = intActR To UBound(aData) '遍历前8行
If i > 8 Then Exit For
vnt = aData(i, j)
If IsNumeric(vnt) Then '是否数值
If VarType(aData(i, j)) = 8 Then '是否文本
strADS = strADS & "," & Cells(1, j + intFirstC - 1).Address
Exit For
End If
End If
Next
Next
strADS = Mid(strADS, 2) '需要设置文本格式的单元格地址
'
aKeys = d.keys '字典Keys，拆分关键字数组
For i = 0 To UBound(aKeys) '遍历关键字
strName = aKeys(i) '关键字
ReDim aRes(1 To d(strName), 1 To UBound(aData, 2)) '结果数组
k = 0 '计数器归0
'
'筛选符合条件的记录存入结果数组
For x = 1 To UBound(aRef)
If aRef(x) = strName Then '如果关键字符合
k = k + 1 '累加符合条件的行
For j = 1 To UBound(aData, 2) '遍历列
aRes(k, j) = aData(x, j) '数据存入结果数组
Next
End If
Next
'
'建立新工作簿，存放结果数组
Set wb = Workbooks.Add
With wb.Worksheets(1)
.Name = strName '命名
If Err.Number Then '如果名称有特殊字符，则退出程序
.Delete
wb.Close False
GoTo errDescript
End If
If Len(strADS) Then
.Range(strADS).EntireColumn.NumberFormat = "@" '特殊列设置为文本格式
End If
With .Cells(intTitCount + 1, intFirstC).Resize(k, UBound(aRes, 2))
.Value = aRes '结果数组数据写入工作表
End With
.UsedRange.Borders.LineStyle = 1 '设置边框线
rngTit.Copy
.Range("a1").PasteSpecial xlPasteColumnWidths '粘贴列宽
.Range("a1").PasteSpecial xlPasteAll '粘贴标题
End With
wb.SaveAs strPath & strName
wb.Close False
Next
errDescript:
shtAct.Select
Call reAppSet '恢复屏幕刷新等系统设置
Set d = Nothing '释放字典内存
If Err.Number Then
MsgBox Err.Description
Else
MsgBox "拆分完成。"
End If
End Sub
'用户选择文件夹路径
Function getStrPath() As String
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else '如用户为选中文件夹则退出
Exit Function
End If
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
getStrPath = strPath
End Function
'获取用户输入的标题行数
Function getTitCount()
Dim intTitCount
intTitCount = InputBox("请输入标题行的行数", _
Title:="公众号Excel星球", _
Default:=1)
If StrPtr(intTitCount) = False Then
getTitCount = False
Exit Function
End If
If IsNumeric(intTitCount) = False Then
MsgBox "标题行的行数只能输入数字。"
getTitCount = False
Exit Function
End If
If intTitCount < 0 Then
MsgBox "标题行数不能为负数。"
getTitCount = False
Exit Function
End If
getTitCount = intTitCount
End Function
'用户选择拆分依据列
Function GetRngGistC() As Range
Dim rngGistC As Range
Set rngGistC = Application.InputBox("请选择拆分依据列。", _
Title:="公众号Excel星球", _
Default:=Selection.Address, _
Type:=8)
If rngGistC Is Nothing Then
Exit Function
End If
If rngGistC.Columns.Count > 1 Then
MsgBox "拆分依据列只能是单列。"
Exit Function
End If
Set GetRngGistC = rngGistC
End Function
'取消屏幕刷新，公式重算等
Sub disAppSet()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
'恢复屏幕刷新等
Sub reAppSet()
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
'最大数据有效行
Function GetintLastR(ByVal sht As Worksheet)
GetintLastR = sht.Cells.Find("*", _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End Function第13至第14行代码，调用getStrPath函数过程，打开文件浏览对话框，允许用户选择任意文件夹作为数据源；如果用户未选取文件夹，则退出程序。
第17至第18行代码，调用getTitCount过程，允许用户输入指定行数的标题行。
第21至第22行代码，调用GetRngGistC过程，允许用户选择拆分依据列。
第24行代码，调用disAppSet过程，取消屏幕刷新等系统设置。
第26至第34行代码将总表数据存入数组aData，并获取获取总表实际存在数据的区域、首列、拆分依据列在实际区域中的第几列、首行和尾行等重要数据。这是由于首行首列未必是第一行第一列，比如本例所示的数据，也就导致拆分依据列的列标未必是实际处理数据的列标。
第35至第39行代码计算标题区域，并赋值变量rngTit。
第41行至第58行代码遍历拆分依据列，处理异常值，比如空格、错误值和可能以"/"为格式的日期值。
第61至第72行代码通过前8行数据判断相关列是否为文本格式，避免文本型数值，比如身份证，在拆分后变形。代码将文本型数值所在的单元格地址赋值变量strADS。
第75至第113行代码按关键字拆分总表数据。其中第82至第89行代码遍历数据源将符合条件的数据存入数组aRes。第92至110行代码新建工作簿，并将结果数组的数据写入该工作簿的首个工作表，并设置标题行。
第118至第122行代码使用MsgBox函数以消息框的形式显示数据拆分结果信息。
……
按指定名单批量创建工作簿
今天给大家分享的VBA代码是按指定名单批量创建工作簿。
打个响指，举个例子，给大家看一张带黄色的图▼
如上图所示，A列是需要批量创建工作簿的名称区域，需要按该名单，批量创建工作簿，并将其保存在代码所在工作簿的相同路径下。
代码演示效果如下▼
示例代码如下：
Sub NewWbBySelection()
Dim rngData As Range, c As Range
Dim strName As String, strPath As String
Dim n As Long, y As Long, strErr As String
On Error Resume Next '忽略程序错误继续运行
Set rngData = getRngData()
If Err.Number Then Exit Sub '如果选择无效区域则退出程序
Call disAppSet '取消屏幕刷新等系统设置
strPath = ThisWorkbook.Path '当前工作簿的路径为新建工作簿保存路径
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
For Each c In rngData '遍历名单
strName = c.Value '工作簿名称
If Len(strName) Then '如果工作簿名称非空
Err.Clear '清除错误
Workbooks.Add '新建工作簿
ActiveWorkbook.SaveAs strPath & strName '保存工作簿
If Err.Number Then '如果存在错误，说明工作簿名称不规范
n = n + 1 '记录问题名称数量
strErr = strErr & "," & strName '记录名称
Else
y = y + 1 '记录正确创建工作簿的数量
End If
ActiveWorkbook.Close , False '关闭不保存
End If
Next
Call reAppSet
If n Then
MsgBox "有" & n & "张工作簿创建失败，原因是工作簿重名或格式错误。" & _
"名单如下：" & vbCrLf & _
Mid(strErr, 2)
ElseIf y Then
MsgBox "创建完成。"
End If
End Sub
Sub disAppSet()
With Application '取消屏幕刷新、信息警告、公式重算等
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.Calculation = xlCalculationManual
End With
End Sub
Sub reAppSet()
With Application '取消屏幕刷新、信息警告、公式重算等
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub
'用户选择名称来源区域
Function getRngData() As Range
Dim rngData As Range
Set rngData = Application.InputBox("请选择新建工作簿名称来源。", _
Title:="提示", _
Default:=Selection.Address, _
Type:=8) '用户选择名称来源区域
Set rngData = Intersect(rngData, rngData.Parent.UsedRange)
'交集运算，避免用户选择整列数据造成运算量虚大或选择区域空白
If rngData Is Nothing Then '如果用户关闭了对话框，或选择区域空白，则退出程序
MsgBox "未选择有效区域。"
Exit Function
End If
Set getRngData = rngData
End Function第6行代码调用getRngData函数，允许用户选择创建工作簿的名单来源区域，如果选择区域无效，则第7行代码退出程序。
第8行代码调用disAppSet过程，取消屏幕刷新、信息警告弹窗、公式重算等系统设置。需要说明的是以下语句：
Application.DisplayAlerts = False该语句的主要作用是取消系统弹出警告信息对话框。当保存的路径下存在相同名称的工作簿时，正常系统会弹出如下警告信息。
而该语句可以取消显示该对话框，直接覆盖保存同名的旧文件。
……
第9至第10行代码获取代码所在工作簿的保存路径，并将其赋值变量strPath。
第11至第25行代码遍历名单，创建工作簿，并保存到strPath路径下。
第17至第22行代码判断工作簿的名称是否违反系统规定，工作簿名称不允许包含如下图所示的几种特殊字符。
如果创建的工作簿名称包含特殊字符，无法正确创建，则使用字符串变量strERR，记录错误名单。
第26行代码调用reAppSet过程，恢复屏幕刷新等系统设置。
第27至第34行代码使用Msgbox语句返回程序处理的结果信息。
指定名称和模板批量创建Excel工作簿
上一期给大家分享了如何按指定名单批量创建工作簿，这期再给大家分享下如何按指定名单和模板批量创建工作簿。
如上图所示，有一张工作表提供了新建工作簿的名单，又有一个工作表名为"模板"，作为新建工作簿的模板。则运行以下代码即可按指定名单和模板批量创建工作簿。
Sub NewWbByTemp()
Dim rngData As Range, c As Range
Dim strName As String, strPath As String
Dim n As Long, y As Long, strErr As String
Dim shtTemp As Worksheet
On Error Resume Next '忽略程序错误继续运行
Set rngData = getRngData() '用户选择名单区域
If Err.Number Then Exit Sub '如果选择无效区域则退出程序
Set shtTemp = Worksheets("模板")
If Err.Number Then
MsgBox "HI，没找到名为模板的工作簿，请核实。"
Exit Sub
End If
Call disAppSet '取消屏幕刷新等系统设置
strPath = ThisWorkbook.Path '当前工作簿的路径为新建工作簿保存路径
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
For Each c In rngData '遍历名单
strName = c.Value '工作簿名称
If Len(strName) Then '如果工作簿名称非空
Err.Clear '清除错误
shtTemp.Copy '复制工作表，不指定位置参数，会成为活动工作簿
ActiveWorkbook.SaveAs strPath & strName '保存工作簿
If Err.Number Then '如果存在错误，说明工作簿名称不规范
n = n + 1 '记录问题名称数量
strErr = strErr & "," & strName '记录名称
Else
y = y + 1 '记录正确创建工作簿的数量
End If
ActiveWorkbook.Close , False
End If
Next
Call reAppSet
If n Then
MsgBox "有" & n & "张工作簿创建失败，原因是工作簿重名或格式错误。" & _
"名单如下：" & vbCrLf & _
Mid(strErr, 2)
ElseIf y Then
MsgBox "创建完成。"
End If
End Sub
Sub disAppSet()
With Application '取消屏幕刷新、信息警告、公式重算等
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.Calculation = xlCalculationManual
End With
End Sub
Sub reAppSet()
With Application '取消屏幕刷新、信息警告、公式重算等
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub
'用户选择名称来源区域
Function getRngData() As Range
Dim rngData As Range
Set rngData = Application.InputBox("请选择新建工作簿名称来源。", _
Title:="提示", _
Default:=Selection.Address, _
Type:=8) '用户选择名称来源区域
Set rngData = Intersect(rngData, rngData.Parent.UsedRange)
'交集运算，避免用户选择整列数据造成运算量虚大或选择区域空白
If rngData Is Nothing Then '如果用户关闭了对话框，或选择区域空白，则退出程序
MsgBox "未选择有效区域。"
Exit Function
End If
Set getRngData = rngData
End Function
代码详细解释见注释……
打个响指，坦白的说，这段代码和上一期代码十分相似，简直是同父异母的哥俩好。第9行至第13行代码，指定名称为"模板"的工作表为新建工作簿的模板；如果当前工作簿查无此表，则退出程序。
第21行代码使用工作表的Copy方法复制一个工作表，但未指定复制后工作表的保存位置；我们上一章讲过，这种情况下，系统会将该工作表转换为活动工作簿。
第22行代码将活动工作簿保存到指定路径下。第23至28行代码判断工作簿名称是否符合规则。其余代码和上一节代码并无二样，也就不需赘言。
VBA按名单删除工作簿、定时自杀工作簿
1 丨删除工作簿
在「什么是工作簿」一章里咱们讲过，删除指定工作簿可以使用Kill语句，示例代码如下▼
Sub DelWB()Dim strPath As StringstrPath = ThisWorkbook.Path & "\公众号Excel星球.xlsx"Kill strPath '删除End Sub
而如果需要删除指定文件夹下全部的工作簿，可以使用以下语句▼
Sub DelAllWorkBooks()Dim strPath As StringstrPath = ThisWorkbook.Path & "\测试\*.xls*"Kill strPathEnd Sub
Kill语句可以从磁盘中删除指定文件，并支持使用通配符匹配文件名。第3行代码指定了文件夹的路径，以及需要删除的文件类型：*.xls*，其中*可以代替0到多个字符，也就代表了Excel各种类型的工作簿。
如果需要删除指定文件夹下的全部文件，代码如下▼
Sub DelAllFiles()Dim strPath As StringstrPath = ThisWorkbook.Path & "\测试\*.*"Kill strPathEnd Sub第3行代码指定了删除文件的类型为*.*，也就是任意文件类型。
2 丨按名单删除工作簿
然后讲一下本章的重点，如何按名单删除符合条件的多个工作簿。
举个例子。
一个文件夹内包含了多个工作簿，可能5个，也可能50个，还可能500个，现在需要删除其中包含多个关键字的，比如包含星光，或者包含Excel，或者包含Word，同时文件类型为Excel工作簿……等等。
我是一个感情世界很丰富的文件夹..▼
处理过程如下▼
首先，使用上一章的代码，将该文件夹内的文件名批量提取到当前活动工作表的A列。
然后在B列使用函数公式或其它方式，标记A列文件名是否需要删除。本例中B2输入以下函数公式，并向下复制填充：
这是一条数组公式▼
=IF(COUNT(SEARCH({"星光","excel","word"},A2)*FIND(".xls",A2)),"删除","")
公式判断条件有两个，第1个是SEARCH({"星光","excel","word"},A2)，判断A2单元格是否至少包含三个关键字中的一个。第2个是SEARCH(".xls",A2)，判断是否包含后缀名.xls。两个条件使用乘法运算，表示并且关系，当两个条件均成立，则返回字符串"删除"，否则返回假空。
公式运算结果如下▼
最后复制运行以下VBA代码，即可删除B列标记为"删除"的A列文件，并在C列返回删除结果报告。
Sub DelWbByNames()
Dim rngData As Range, aData, aRes
Dim i As Long, strMSG As String, n As Long
Dim strPath As String, strName As String
On Error Resume Next
Set rngData = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
aData = rngData '数据存入数组
ReDim aRes(1 To UBound(aData), 1 To 1) '结果数组
Application.ScreenUpdating = False
strPath = getStrPath() '获取文件夹路径
If strPath = "" Then Exit Sub
For i = 2 To UBound(aData) '扣掉标题行遍历数组
If aData(i, 2) = "删除" Then '如果B列标记删除
strName = Dir(strPath & aData(i, 1))
If strName <> "" Then '判断是否存在相关文件
Err.Clear
Kill strPath & strName '删除文件
If Err.Number Then '如果程序错误
aRes(i, 1) = "删除失败"
n = n + 1
Else
aRes(i, 1) = "删除成功"
End If
Else
aRes(i, 1) = "查无文件"
n = n + 1
End If
End If
Next
Columns(3).ClearContents
aRes(1, 1) = "处理结果"
Range("c1").Resize(UBound(aRes, 1)) = aRes '处理结果写会Excel
Application.ScreenUpdating = True
strMSG = "处理完成。"
If n Then strMSG = strMSG & vbCrLf & _
"有" & n & "个文件删除失败," & _
"需核对文件名、后缀或路径是否正确。"
MsgBox strMSG
End Sub
'用户选择文件夹
Function getStrPath() As String
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else '如用户为选中文件夹则退出
Exit Function
End If
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
getStrPath = strPath
End Function代码详细解释见注释，概要说明如下▼
第6、7行代码将A:B列的数据存入数组aData。
第8行代码调整结果数组aRes的大小。
第10行代码调用getStrPath函数过程，允许用户自定义选择文件夹路径。
第12至第29行代码遍历数据源数组aData。如果数组第2列内容等于关键字"删除"，则执行删除相关文件的语句。第14行代码使用Dir函数判断相关文件是否存在。如果存在，删除文件后，在结果数组写入字符串"删除成功"；如果删除过程中出现程序错误，则在结果数组中写入字符串"删除失败"。
第30至第32行代码将结果数组写入当前工作表。
第34至第38行代码使用MsgBox语句弹出消息框显示程序处理结果。
3 丨制作定时自杀的工作簿
最后再给大家分享下如何制作定时自杀的工作簿。
示例代码如下:
Private Sub Workbook_Open()
Dim dat As Date
dat = DateSerial(2219, 10, 1) '自杀日期
If Date >= dat Then
On Error Resume Next
Application.DisplayAlerts = False '取消警告信息
MsgBox "表生自古谁不死？留取担心找汉卿，走了你。"
With ThisWorkbook
.Saved = True '保存
.ChangeFileAccess xlReadOnly '只读
Kill .FullName '杀死自己
.Close '关闭不保存
End With
Application.DisplayAlerts = True
End If
End Sub第3行代码使用DateSerial函数指定一个日期，并赋值变量dat，第4行代码判断当前日期是否大于或等于dat，如果条件成立，则执行自杀计划。
第8行代码使用With语句引用代码所在工作簿对象。
第9行代码将该工作簿的Saved属性修改为True，为的是避免切换文件读写状态时出现系统警告信息对话框。
第10行代码使用ChangeFileAccess方法将工作簿的访问权限修改为只读。在只读状态下，Kill语句可以删除打开的工作簿，而不返回程序错误。
第11行代码使用工作簿的FullName属性返回代码所在工作簿的完整路径，然后使用Kill语句杀死它。
第12行代码关闭工作簿，盖木欧瓦。
需要汇总多工作簿数据到总表？一个模版一键搞定~
今天分享一段VBA代码，作用是将指定文件夹下全部excel或csv类型文件的数据汇总到当前工作表。照例代码复制即可使用，或者文末下载模版，点击按钮即可完成既定目标。
相关代码及操作说明如下▼
如下图所示的文件夹，包含了Excel/csv等多个文件，每个Excel工作簿内又包含了多张工作表……
现在需要由用户自由选择数据来源文件夹，将所有数据汇总为一张工作表。标题行的行数也由用户自由指定；汇总后的数据需保持文本型数值不变形；并提供数据来源工作簿名、工作表名以及工作表序号等，以方便后续数据筛选处理。
动画演示效果如下：
示例代码如下▼
Sub GetFilesDataByNUM()
Dim aFileName(), strPath As String
Dim i As Long, x As Long, k As Long, intTitCount
Dim wb As Workbook, sht As Worksheet, shtSum As Worksheet
Dim rngData As Range
Dim intLastRow As Long, intFirstRow As Long
Dim aData, aSource
On Error Resume Next
strPath = getStrPath() '用户选择路径
If strPath = "" Then Exit Sub
intTitCount = getTitCount() '用户设置标题行数
If intTitCount = "错误" Then Exit Sub
aFileName = GetWbFullNames(strPath) '获取文件名单
Call disAppSet '取消屏幕刷新
Call CreateShtSum '创建汇总数据的工作表
Set shtSum = Worksheets("星光-汇总")
intFirstRow = 1
For i = 1 To UBound(aFileName) '遍历文件
Set wb = Workbooks.Open(aFileName(i))
For Each sht In wb.Worksheets '遍历工作表
Set rngData = sht.UsedRange
If IsEmpty(rngData) = False Then '如果工作表非空
k = k + 1
'数据来源的工作簿、工作表等信息
aSource = Array(wb.Name, sht.Name, sht.Index)
If k = 1 Then
aData = rngData.Value
'根据首张工作表，设置可能有的文本值格式
Call DataFormat(aData, shtSum)
Else
aData = rngData.Offset(intTitCount).Value
End If
With shtSum '数据写入工作表
.Cells(intFirstRow, 4).Resize( _
UBound(aData), UBound(aData, 2)) = aData
intLastRow = GetLastRow(shtSum) '结束行
.Range(.Cells(intFirstRow, 1), .Cells(intLastRow, 3)) _
.Value = aSource '来源信息写入工作表
intFirstRow = intLastRow + 1
End With
End If
Next
wb.Close False
Next
shtSum.Select
Range("a1:c1") = Array("工作簿名称", "工作表名称", "工作表索引")
Cells.EntireColumn.AutoFit
Call reAppSet
If Err.Number Then
MsgBox Err.Description
Else
MsgBox "汇总完成。"
End If
End Sub
'用户选择文件夹路径
Function getStrPath() As String
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else '如用户为选中文件夹则退出
Exit Function
End If
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
getStrPath = strPath
End Function
'获取用户输入的标题行数
Function getTitCount()
Dim intTitCount
intTitCount = InputBox("请输入标题行的行数", _
Title:="公众号Excel星球", _
Default:=1)
If StrPtr(intTitCount) = False Then
getTitCount = "错误"
Exit Function
End If
If IsNumeric(intTitCount) = False Then
MsgBox "标题行的行数只能输入数字。"
getTitCount = "错误"
Exit Function
End If
If intTitCount < 0 Then
MsgBox "标题行数不能为负数。"
getTitCount = "错误"
Exit Function
End If
getTitCount = intTitCount
End Function
'判断是否文本格式，由前10行决定
Sub DataFormat(ByRef aData As Variant, shtSum As Worksheet)
Dim i As Long, j As Long
Dim vnt, strADS
For j = 1 To UBound(aData, 2) '遍历列
For i = 1 To UBound(aData) '遍历前10行
If i > 10 Then Exit For
vnt = aData(i, j)
If IsNumeric(vnt) Then '是否数值
If VarType(aData(i, j)) = 8 Then '是否文本
strADS = strADS & "," & Cells(1, j + 3).Address
Exit For
End If
End If
Next
Next
strADS = Mid(strADS, 2) '需要设置文本格式的单元格地址
If Len(strADS) Then
shtSum.Range(strADS).EntireColumn.NumberFormat = "@"
End If
End Sub
'获取文件名名单
Function GetWbFullNames(strPath As String)
Dim strName As String, strTemp As String
Dim aRes(), k As Long
strName = Dir(strPath & "*.*")
Do While strName <> ""
strTemp = Right(strName, 4)
If strTemp Like "*xls*" Or strTemp Like "*csv*" Then
k = k + 1
ReDim Preserve aRes(1 To k)
aRes(k) = strPath & strName
End If
strName = Dir()
Loop
GetWbFullNames = aRes
End Function
'创建汇总表
Sub CreateShtSum()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name = "星光-汇总" Then sht.Delete
Next
Worksheets.Add , Sheets(1)
ActiveSheet.Name = "星光-汇总"
End Sub
'查询有效数据最大行
Function GetLastRow(shtData As Worksheet)
GetLastRow = shtData.Cells.Find("*", _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End Function
Sub disAppSet() '撤销屏幕刷新
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.AskToUpdateLinks = False
.Calculation = xlCalculationManual
End With
End Sub
Sub reAppSet() '恢复屏幕刷新等
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub代码详细解释见注释，概要说明如下。
第9至第10行代码，调用getStrPath函数过程，打开文件浏览对话框，允许用户选择任意文件夹；如果用户未选取文件夹，则退出程序。
第11至第12行代码，调用getTitCount函数过程，通过InputBox语句，获取用户设置的标题行的行数。
第13行代码，GetWbFullNames函数过程，利用Dir语句获取指定文件夹下符合汇总条件的文件路径数组集合。
第14行代码取消屏幕刷新等系统设置。
第15行代码在当前工作簿创建一张名为"星光-汇总"的工作表。
第18至第44行代码遍历文件。
其中第19行代码打开工作簿，第20至第42行代码遍历工作簿内的工作表。第22行代码判断工作表是否非空，如果不为空，则继续判断是否汇总的首张工作表。如果是首张工作表，则根据前10行数据调整汇总工作表的单元格格式，避免文本型数值变形。
第33至39行代码将数组的数据写入汇总工作表，并在前3列写入数据来源的工作簿名称、工作表名称以及工作表序号。
第44行代码关闭工作簿，执行下一个文件。
第48行代码恢复屏幕刷新等系统设置。
第49至第53行代码弹窗告知用户汇总结果。
如何将指定文件夹下所有工作簿的工作表移动到当前工作簿？
牵牵爪子，一起看个小视频，了解下模版运行过程和效果。
如需实现以上动画展示的功能，示例代码如下▼
Sub GetSheetsCopy()
Dim strPath As String, strBookName As String, strKey As String
Dim strShtName As String, k As Long, wb As Workbook
Dim sht As Worksheet, shtActive As Worksheet
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 & "\"
strKey = InputBox("请输入工作表名称所包含的关键词。" & vbCr _
& "关键词可以为空，如为空，则默认移动全部工作表")
If StrPtr(strKey) = 0 Then Exit Sub
Set shtActive = ActiveSheet '当前工作表，代码运行完毕后，回到此表
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.Calculation = xlManual
End With
strBookName = Dir(strPath & "*.xls*")
Do While strBookName <> ""
If strBookName = ThisWorkbook.Name Then
MsgBox "注意：指定文件夹中存在和当前工作簿重名的工作簿！！" & vbCr & "该工作簿无法打开，工作表无法复制。" '当出现重名工作簿时，提醒用户。
Else
Set wb = Workbooks.Open(strPath & strBookName)
For Each sht In wb.Worksheets
If IsEmpty(sht.UsedRange) = False Then
If InStr(1, sht.Name, strKey, vbTextCompare) Then '工作表名称是否包含关键词，关键词不区分大小写
strShtName = Split(strBookName, ".xls")(0) & "-" & sht.Name '复制来的工作表以"工作簿-工作表"形式起名。
ThisWorkbook.Sheets(strShtName).Delete '如果已存在相关表名，则删除
sht.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) '复制到代码所在工作簿
k = k + 1 '复制Sht到代码所在工作簿所有工作表的后面，并累计个数
ActiveSheet.Name = strShtName '工作表命名
End If
End If
Next
wb.Close False '关闭工作簿，不保存
End If
strBookName = Dir '下一个符合条件的文件
Loop
shtActive.Select '回到初始工作表
MsgBox "工作表收集完毕，共收集：" & k & "个"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
.Calculation = xlAutomatic
End With
End Sub如何按相同工作表名称，批量汇总多工作簿数据到总表？
在实际工作中，我们也可能碰到下面这种情况：
每个工作簿包含数量不一、名称相同的工作表，在汇总数据时，需要按工作表名称分别汇总。比如，名为财务部的工作表单独汇总成一张工作表，名为销售部的也单独汇总成一张工作表……
动画演示如下：
打个响指，复制粘贴运行以下代码即可解决此类问题。
Sub GetEachShtData()
Dim i As Long, intLastRow As Long
Dim shtSum As Worksheet, shtAct As Worksheet, shtData As Worksheet
Dim aFileName, wb As Workbook, d As Object
Dim strFileName As String, strPath As String, strShtName As String
On Error Resume Next
strPath = getStrPath() '用户选择路径
If strPath = "" Then Exit Sub
aFileName = GetWbFullNames(strPath) '获取文件名单
If IsArray(aFileName) = False Then Exit Sub
Call disAppSet '取消屏幕刷新等
Call delsht '调用删除工作表过程
Set d = CreateObject("scripting.dictionary")
Set shtAct = ActiveSheet '当前工作表
Set wb = ThisWorkbook '代码所在工作簿
For i = 1 To UBound(aFileName) '遍历工作簿
With Workbooks.Open(aFileName(i), False) '打开工作簿不更新链接
For Each shtData In .Worksheets
If shtData.FilterMode = True Then shtData.Cells.AutoFilter '取消筛选
strShtName = shtData.Name '工作表名称
If Not d.exists(strShtName) Then
d(strShtName) = "" '工作表移动到代码所在工作簿
shtData.Copy after:=wb.Worksheets(wb.Sheets.Count)
Else
Set shtSum = wb.Worksheets(strShtName)
intLastRow = GetLastRow(shtSum) + 1 '最后存在数据的行
shtData.UsedRange.Copy shtSum.Cells(intLastRow, 1) '复制粘贴
End If
Next
.Close False '关闭不保存
End With
Next
Call reAppSet '恢复系统设置
Set d = Nothing
shtAct.Select
If Err.Number Then
MsgBox Err.Description
Else
MsgBox "汇总完成。"
End If
End Sub
'用户选择文件夹路径
Function getStrPath() As String
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else '如用户为选中文件夹则退出
Exit Function
End If
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
getStrPath = strPath
End Function
'获取文件名名单
Function GetWbFullNames(strPath As String)
Dim strShtName As String, strTemp As String
Dim aRes(), k As Long
k = 0
strShtName = Dir(strPath & "*.*")
Do While strShtName <> ""
strTemp = Right(strShtName, 4)
If strTemp Like "*xls*" Or strTemp Like "*csv*" Then
k = k + 1
ReDim Preserve aRes(1 To k)
aRes(k) = strPath & strShtName
End If
strShtName = Dir()
Loop
GetWbFullNames = aRes
End Function
'查询有效数据最大行
Function GetLastRow(shtData As Worksheet)
GetLastRow = shtData.Cells.Find("*", _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End Function
Sub delsht()
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> ActiveSheet.Name Then sht.Delete
Next
End Sub
Sub disAppSet() '撤销屏幕刷新
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.AskToUpdateLinks = False
.Calculation = xlCalculationManual
End With
End Sub
Sub reAppSet() '恢复屏幕刷新等
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub代码详细解释见注释，概要说明如下：
第7至第8行代码，调用getStrPath函数过程，打开文件浏览对话框，允许用户选择任意文件夹作为数据源；如果用户未选取文件夹，则退出程序。
第9至第10行代码，调用GetWbFullNames函数过程，利用Dir语句获取指定文件夹下符合汇总条件的文件路径数组集合。
第11行代码取消屏幕刷新等系统设置。
第12行代码删除代码所在工作簿除了当前工作表以外的所有工作表。
第16至第32行代码遍历打开指定文件夹下的Excel或csv文件。
第18至第29行代码遍历工作簿的工作表。
第21行代码判断字典中是否存在相关工作表名称；如果不存在，则将整表复制移动到代码所在工作簿；如果存在，则只将数据复制粘贴到相关工作表。
第30行代码恢复系统屏幕刷新等设置。
第36至第40行代码弹窗告知用户汇总结果。
如何获取指定文件夹下文件名并创建超链接？
先看一个动画效果演示▼
代码允许用户自由选择文件，然后自动获取该文件夹下所有文件的名字，并存放在当前工作表的A列。
实现代码如下：
Sub GetlWbNames()
Dim strPath As String, strName As String
Dim k As Long
strPath = getStrPath() '获取用户选中文件夹的路径
If strPath = "" Then Exit Sub '如果用户为选择文件夹，则退出程序
Application.ScreenUpdating = False
With ActiveSheet.Columns(1)
.Clear '清空A列
.NumberFormat = "@" '设置文本格式
End With
k = 1
Cells(k, 1) = "目录"
strName = Dir(strPath & "*.*")
Do While strName <> ""
k = k + 1 '计数器
Cells(k, 1) = strName
strName = Dir() '第2次调用dir函数但未带参数
Loop
Application.ScreenUpdating = True
MsgBox "OK"
End Sub
Function getStrPath() As String
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else '如用户为选中文件夹则退出
Exit Function
End If
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
getStrPath = strPath
End Function第4行代码调用getStrPath函数过程，打开【文件浏览】对话框，允许用户选择的目标文件夹，并获取相关文件的路径。
第13行代码使用Dir函数获取指定路径下的首个文件名。Dir函数是VBA编程中文件处理最常使用的函数之一，可以返回代表文件或文件夹名的字符串。它的相关语法和特点，我们在「什么是条件循环」一章详细讲过了，不知你是否还记得？——出门右转戳「知识星球」第一个置顶帖→「VBA编程系列教程」→第14课什么是条件循环→第3小节：一个经典的条件循环案例。
第14行代码判断Dir函数返回结果是否不为空。按照Dir函数的特点，查无结果将返回零长度的字符串，因此这里可以判断是否存在文件名；如果存在文件名则执行循环体内的语句，否则结束循环。
第15行代码累加行数，第16行代码将文件名写入A列单元格。
第17行代码第2次调用Dir函数，但未使用任何参数；按照Dir函数的特点，它会查找同目录下的下一个文件名。
3万+
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
