VBA：demo大全

VBA常用小代码合集，总有一个是您用得上的~ (qq.com)

如何在各个分表创建返回总表的命令按钮？

今天再来给大家聊一下如何使用VBA代码，只需一键，即可在各个分表生成返回总表的按钮。

示例代码如下：

Sub Mybutton()Dim sht As Worksheet, btn As Button, strShtName As StringOn Error Resume NextstrShtName = "总表"For Each sht In WorksheetsIf sht.Name <> strShtName Thensht.Shapes(strShtName).Delete '删除原有的名称为shtn的按钮，避免重复创建Set btn = sht.Buttons.Add(0, 0, 60, 30) '新建按钮，释义见小贴士With btn.Name = strShtName '命令按钮命名.Characters.Text = "返回总表" '按钮的文本内容.OnAction = "LinkTable" '指定按钮控件所执行的宏命令End WithEnd IfNextSet btn = Nothing
End Sub
'_________________________________________
Sub LinkTable()Dim trShtName As StringstrShtName = "总表" '设置变量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 WorksheetFor Each sht In Worksheets '遍历工作表，设置可见sht.Visible = xlSheetVisibleNext
End Sub

如果只需要取消隐藏部分工作表，可以在代码中添加条件判断语句，将需要隐藏的工作表名称写在以下代码的第3行中，并以"/"作为分隔符合并即可。

Sub unShtVisible()Dim sht As Worksheet, tt = "看见星光/Excel星球/Sheet5/" '将需要隐藏的工作表名称写在这For Each sht In Worksheets '遍历工作表，设置可见If InStr(t, sht.Name &"/") Thensht.Visible = xlSheetVisibleEnd IfNext
End Sub

VBA：如何批量修改工作表名称？

本章给大家分享的内容是使用VBA代码对工作表批量重命名。举个例子，如下图所示，一个工作簿里包含了多张工作表，现在需要在每张工作表名称前增加一个前缀词"星光"。

操作步骤如下▼

首先使用以下代码将工作表的名称罗列在当前表的A列；相关代码我们在如何遍历工作表中分享过了，不知道你是否还记得：

Sub GetShName()Dim sht As Worksheet, k As LongApplication.ScreenUpdating = FalseWith Range("a:a").Clear '清除所有.NumberFormat = "@" '设置文本格式End Withk = 1Cells(1, 1) = "目录"For Each sht In Sheets '遍历工作表k = k + 1 '累加个数Cells(k, 1) = sht.NameNextApplication.ScreenUpdating = True
End Sub

示例文件中代码返回结果如下：

然后在B列对A列的表名添加新名字，可以根据具体的规则，使用不同的函数进行处理。本例的规则比较简单，B列输入以下公式即可。

="星光-"&A2

最后使用以下代码按照A:B列的数据对工作表批量重命名。

Sub NewShName()Dim aData, aRes, i As LongIf ActiveWorkbook.ProtectStructure = True ThenMsgBox "工作簿有保护，工作表无法重命名。"Exit SubEnd IfApplication.ScreenUpdating = FalseOn 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) <> "" ThenSheets(aData(i, 1)).Name = aData(i, 2)If Err.Number Then '如果有错aRes(i, 1) = "更名失败"ElseaRes(i, 1) = "成功"End IfElseaRes(i, 1) = "空白值"End IfNextRange("c1").Resize(UBound(aRes), 1) = aResApplication.ScreenUpdating = TrueMsgBox "更名完成，结果参考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 LongApplication.ScreenUpdating = FalseWith Range("a:a").Clear '清除所有.NumberFormat = "@" '设置文本格式End Withk = 1Cells(1, 1) = "目录"For Each sht In Sheets '遍历工作表k = k + 1 '累加个数Cells(k, 1) = sht.NameNextApplication.ScreenUpdating = True
End Sub

示例文件中代码返回结果如下：

然后对A列数据进行排序，这个时候你可以用各种手段修理它们，升序、降序、自定义排序、基操、函数等等，你爱怎么着就怎么着，开心就好。

(#^.^#)
最后使用以下代码按照A列排序后的数据对工作表重新排放位置。

Sub SortSh()Dim sht As Worksheet, shtAct As WorksheetDim aData, i As Long, intCount As LongDim strName As String, strErr As StringOn Error Resume Next '忽略程序错误继续运行If ActiveWorkbook.ProtectStructure = True ThenMsgBox "工作簿有保护，工作表无法排序。"Exit SubEnd IfApplication.ScreenUpdating = FalseaData = 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 & "," & strNameElse'移动到最后一个工作表之后sht.Move after:=Sheets(intCount)End IfNextIf strErr <> "" ThenMsgBox "以下工作表名称工作簿中不存在" & vbCr _& Mid(strErr, 2)ElseMsgBox "排序完成。"End IfshtAct.Select '回到操作表Application.ScreenUpdating = True
End Sub

代码详细解析见注释，概要解释如下▼

第11行代码将A列的数据存入数组aData。

第14至第24行代码遍历数组。依次将相关工作表名移动到最后一张工作表之后——听说每个人都有一个梦想，做一名人民教师，为的不是教书育人，而是点名扔粉笔头。代码运行的场景大概就是这样：你化身人民教师，先将工作表排成一排，让他们按身高或亲疏依次站到排尾，也就实现有序排列…

第18行代码使用试错法判断当前工作簿是否存在相关工作表名称，该方法我们在如何遍历工作表中也详细解释过了

批量工作表加密

以下代码可以为当前工作簿的工作表批量加密。

Sub ProtectSht()Dim strAds As String, sht As WorksheetDim strKey As String, strTemp As StringDim rng As Range, strMsg As StringDim strNoShtName As String, strYesShtName As StringOn Error Resume NextstrAds = InputBox("请输入单元格保存范围，例如A1:B10." & vbCr _& "可以设置不连续单元格，中间请以逗号分隔。比如A1:B10,D2:D8" & vbCr _& "如果需要全表保护，可以直接确定。", Default:="全表保护")If StrPtr(strAds) = False Then Exit SubIf strAds = "全表保护" Then strAds = Cells.AddressSet rng = Range(strAds) '测试输入的单元格区域是否有效If Err Then MsgBox "你输入的单元格区域地址不是正确的格式，请重新操作。": Exit SubstrKey = InputBox("请输入保护密码。") '第一次输入密码If StrPtr(strKey) = False Then Exit SubstrTemp = InputBox("请再次输入保护密码。") '第二次输入密码If StrPtr(strKey) = False Then Exit SubIf strKey <> strTemp Then MsgBox "你两次输入的密码不一致，系统退出，请重新操作。": Exit SubFor Each sht In Worksheets '遍历工作表加密保护With shtIf .ProtectContents = False Then '如果工作表未保护.Cells.Locked = False '全部单元格区域取消锁定.Range(strAds).Locked = True '需要保护的区域锁定.Protect strKey, True, True, True '保护工作表，只允许编辑非锁定区域strYesShtName = strYesShtName & "," & .Name '保护成功的工作表名称ElsestrNoShtName = strNoShtName & "," & .Name '自身已有保护功能的工作表End IfEnd WithNextIf 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 RangeDim i As Long, intLastRow As LongDim intTitCount, intYesOrNo As StringDim rngLast As Range, rngFirst As RangeintTitCount = getTitCount() '获取用户输入的标题行数If intTitCount = False Then Exit SubintYesOrNo = MsgBox("是否需要保留源表格式、公式等？", vbYesNo)Call disAppSet '取消屏幕刷新，公式重算等Cells.Clear '清空当前表数据For Each sht In Worksheets '遍历工作表If sht.Name <> ActiveSheet.Name ThenSet rngData = sht.UsedRange '有效单元格区域If IsEmpty(rngData) = False Then '判断工作表是否非空If sht.AutoFilterMode = True Thensht.Cells.AutoFilter '取消筛选，避免数据复制遗漏End Ifk = 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 '填充工作表名称ElserngData.Offset(intTitCount).Copy '扣除标题复制Call rngPaste(Cells(rngLast.Row + 1, 2), intYesOrNo)intLastRow = GetIntLastRowSet rngFirst = rngLast.Offset(1) '开始单元格Set rngLast = Cells(intLastRow, 1) '结束单元格Range(rngFirst, rngLast) = sht.Name '填充工作表名称End IfEnd IfEnd IfNextCall rngFormat(intTitCount)Call reAppSet '恢复屏幕刷新等MsgBox "一共汇总了" & k & "张工作表。"
End Sub'获取用户输入的标题行数
Function getTitCount()Dim intTitCountintTitCount = InputBox("请输入标题行的行数", _Title:="公众号Excel星球", _Default:=1)If StrPtr(intTitCount) = False ThengetTitCount = FalseExit FunctionEnd IfIf IsNumeric(intTitCount) = False ThenMsgBox "标题行的行数只能输入数字。"getTitCount = FalseExit FunctionEnd IfIf intTitCount < 0 ThenMsgBox "标题行数不能为负数。"getTitCount = FalseExit FunctionEnd IfgetTitCount = intTitCount
End Function'取消屏幕刷新，公式重算等
Sub disAppSet()With Application.ScreenUpdating = False.Calculation = xlCalculationManual.DisplayAlerts = FalseEnd With
End Sub'恢复屏幕刷新等
Sub reAppSet()With Application.ScreenUpdating = True.Calculation = xlCalculationAutomatic.DisplayAlerts = TrueEnd 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 '粘贴全部Elserng.PasteSpecial xlPasteValues '粘贴数值End If'Application.CutCopyMode = False
End Sub'将B列格式复制到A列
Sub rngFormat(ByVal intTitCount As Long)Range("b:b").CopyWith Range("a1").PasteSpecial xlPasteFormats '粘贴B列格式.Value = "工作表名" '填写工作表来源.Resize(intTitCount, 1).Merge '合并多行标题.HorizontalAlignment = xlCenter '水平居中.VerticalAlignment = xlCenter '垂直居中.EntireColumn.AutoFit '自动列宽.SelectEnd 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, aResDim i As Long, j As Long, k As LongDim strKey As String, strShtName As String, n As LongDim sht As Worksheet, rngData As Range, shtAct As WorksheetDim intLastRow As Long, y As LongSet d = CreateObject("scripting.dictionary")Set shtAct = ActiveSheetOn Error Resume NextCall disAppSetCells.Clear '清空当前表Cells.NumberFormat = "@" '设置文本格式，避免文本数值变形Cells(1, 1) = "工作表名称" 'A列放工作表名称k = 1 '计数器初始化For Each sht In Worksheets '遍历工作表strShtName = sht.Name '工作表名称If strShtName <> ActiveSheet.Name ThenIf 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.ValueIf 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) Thenk = k + 1 '累加不同字段的个数If k > UBound(aRes, 2) Then '重新调整结果数组大小ReDim Preserve aRes(1 To UBound(aRes), 1 To k)End Ifd(strKey) = k '定义字段名在结果数组中的位置For i = 1 To UBound(aData) '如果前8行有日期则整列设置日期格式If i > 8 Then Exit ForIf IsDate(aData(i, j)) ThenshtAct.Cells(i, j + 1). _EntireColumn.NumberFormat = "yyyy-m-d"Exit ForEnd IfNextEnd Ify = d(strKey) '字段在结果数组中的列位置For i = 2 To UBound(aData) '遍历行aRes(i - 1, y) = aData(i, j) '存入结果数组NextNextFor i = 2 To UBound(aData) 'A列作为工作表来源字段aRes(i - 1, 1) = strShtName '填写工作表名称NextEnd IfintLastRow = GetIntLastRow(shtAct) + 1 '最后存在数据的行Cells(intLastRow, 1).Resize(UBound(aRes), UBound(aRes, 2)) = aResEnd IfEnd IfNextshtAct.Range("b1").Resize(1, k - 1) = d.keys '标题行数据Call reAppSet '恢复屏幕刷新等Set d = Nothing '释放字典If Err.Number ThenMsgBox Err.DescriptionElseMsgBox "一共汇总了" & n & "张工作表。"End If
End Sub'取消屏幕刷新，公式重算等
Sub disAppSet()With Application.ScreenUpdating = False.Calculation = xlCalculationManual.DisplayAlerts = FalseEnd With
End Sub'恢复屏幕刷新等
Sub reAppSet()With Application.ScreenUpdating = True.Calculation = xlCalculationAutomatic.DisplayAlerts = TrueEnd 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 WorksheetDim rngData As Range, rngGistC As Range, rngTemp As RangeDim d As Object, aData, aKeys, vntDim intTitCount, strKey As String, strName As StringDim strADS As String, rngTit As RangeDim i As Long, j As Long, intFirstR As Long, intLastR As LongDim k As Long, x As Long, intActR As LongDim 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 '总表数据存入数组aDataintFirstC = rngData.Column '实际区域开始列intGistC = rngGistC.Column - intFirstC + 1 '依据列在aData中的序列intFirstR = rngData.Row '实际区域开始行intActR = intTitCount - intFirstR + 2 '扣除标题的数组开始行intLastR = GetintLastR(shtAct) '实际区域结束行With shtActSet 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) ThenaRef(i) = "错误值"ElseIf vnt = "" ThenaRef(i) = "空白单元格"ElseIf IsDate(vnt) Then '避免日期斜杠格式无法创建工作表aRef(i) = Format(vnt, "yyyy-m-d")ElseaRef(i) = vntEnd IfstrKey = 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 Forvnt = aData(i, j)If IsNumeric(vnt) Then '是否数值If VarType(aData(i, j)) = 8 Then '是否文本strADS = strADS & "," & Cells(1, j + intFirstC - 1).AddressExit ForEnd IfEnd IfNextNextstrADS = 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) '数据存入结果数组NextEnd IfNext''建立新工作表，存放结果数组DelSht (strName) '删除重名工作表With Worksheets.Add(after:=Sheets(Sheets.Count)) '新建工作表.Name = strName '命名If Err.Number Then '如果名称有特殊字符，则退出程序.DeleteGoTo errDescriptEnd IfIf Len(strADS) Then.Range(strADS).EntireColumn.NumberFormat = "@" '特殊列设置为文本格式End IfWith .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 WithNext
errDescript:shtAct.SelectCall reAppSet '恢复屏幕刷新等系统设置Set d = Nothing '释放字典内存If Err.Number ThenMsgBox Err.DescriptionElseMsgBox "拆分完成。"End If
End Sub'获取用户输入的标题行数
Function getTitCount()Dim intTitCountintTitCount = InputBox("请输入标题行的行数", _Title:="公众号Excel星球", _Default:=1)If StrPtr(intTitCount) = False ThengetTitCount = FalseExit FunctionEnd IfIf IsNumeric(intTitCount) = False ThenMsgBox "标题行的行数只能输入数字。"getTitCount = FalseExit FunctionEnd IfIf intTitCount < 0 ThenMsgBox "标题行数不能为负数。"getTitCount = FalseExit FunctionEnd IfgetTitCount = intTitCount
End Function'用户选择拆分依据列
Function GetRngGistC() As RangeDim rngGistC As RangeSet rngGistC = Application.InputBox("请选择拆分依据列。", _Title:="公众号Excel星球", _Default:=Selection.Address, _Type:=8)If rngGistC Is Nothing ThenExit FunctionEnd IfIf rngGistC.Columns.Count > 1 ThenMsgBox "拆分依据列只能是单列。"Exit FunctionEnd IfSet GetRngGistC = rngGistC
End Function'取消屏幕刷新，公式重算等
Sub disAppSet()With Application.ScreenUpdating = False.Calculation = xlCalculationManual.DisplayAlerts = FalseEnd With
End Sub'恢复屏幕刷新等
Sub reAppSet()With Application.ScreenUpdating = True.Calculation = xlCalculationAutomatic.DisplayAlerts = TrueEnd With
End Sub'删除重名工作表
Function DelSht(ByVal strName As String)Dim sht As WorksheetFor Each sht In WorksheetsIf sht.Name = strName Thensht.DeleteExit FunctionEnd IfNext
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 RangeDim ans As VbMsgBoxResultFor Each rCell In TargetWith rCellIf Len(.Value) > 0 Thenans = MsgBox("输入正确吗?" & vbCrLf & vbCrLf & _vbTab & .Value & "  (" & .Address(False, False) & ")" & vbCrLf & vbCrLf & _"输入数值后将不能编辑这个单元格.", vbYesNo, "单元格锁定通知")If ans = vbYes ThenIf Me.ProtectContents ThenMe.Unprotect Password:="123"  '首先撤销保护.Locked = TrueMe.ProtectPassword:="123"Else.ClearContentsActiveCell.Offset(-1, 0).Select  '重新选择数据输入单元格End IfEnd IfEnd WithNext rCell
End Sub

这里，假设锁定工作表的密码为“123”。

可以使用右击单元格的方式，来重置想要重新输入数据的单元格。在该工作表代码模块中添加下面的代码：

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)Dim rCell As RangeDim ans As VbMsgBoxResultFor Each rCell In Target.CellsWith rCellIf Len(.Value) > 0 Thenans = MsgBox("你想要重置这个单元格吗?" & vbCrLf & vbCrLf & _vbTab & .Value & "  (" & .Address(False, False) & ")", vbYesNo, "单元格锁定通知")If ans = vbYes ThenIf ActiveSheet.ProtectContents Then ActiveSheet.Unprotect Password:="123"  '首先撤销保护Application.EnableEvents = False.ClearContents.Locked = FalseApplication.EnableEvents = TrueActiveSheet.Protect Password:="123"End IfEnd IfEnd WithNextCancel = True
End Sub

这样，右击想要重新输入数据的单元格，会弹出一个消息框，询问你是否要重置这个单元格，如果点击“是”，则会清空该单元格并供输入新数据。

效果如下图1所示。

一键将工作表批量转换为独立的工作簿

将工作表批量转换为独立的工作簿，并保存到指定文件夹下？

举个例子，如下图所示▼

坦白的说，代码三五行，工作不用忙断肠，方法当然是有的。
看个效果动画：

运行以下VBA代码即可实现工作表转工作簿的操作。

Sub EachShtToWorkbook()Dim sht As Worksheet, strPath As StringWith Application.FileDialog(msoFileDialogFolderPicker)'选择保存工作薄的文件路径If .Show Then strPath = .SelectedItems(1) Else Exit Sub'读取选择的文件路径,如果用户未选取路径则退出程序End WithIf 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 WithNextMsgBox "处理完成。", , "提醒"Application.ScreenUpdating = True '恢复屏幕刷新Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub

将总表按任意列拆分为多个工作簿

如下图所示，是一张总表，现在需要按任意列，比如班级列吧，将它拆分为多个工作簿。

动画演示如下：

VBA代码如下（复制即可使用）

Sub SplitShByArr()Dim shtAct As Worksheet, sht As Worksheet, wb As WorkbookDim rngData As Range, rngGistC As Range, rngTemp As RangeDim d As Object, aData, aKeys, vntDim intTitCount, strKey As String, strName As StringDim strADS As String, rngTit As RangeDim i As Long, j As Long, intFirstR As Long, intLastR As LongDim k As Long, x As Long, intActR As LongDim intFirstC As Long, intGistC As LongDim strPath As StringOn 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 '总表数据存入数组aDataintFirstC = 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) ThenaRef(i) = "错误值"ElseIf vnt = "" ThenaRef(i) = "空白单元格"ElseIf IsDate(vnt) Then '避免日期斜杠格式无法创建工作簿/表aRef(i) = Format(vnt, "yyyy-m-d")ElseaRef(i) = vntEnd IfstrKey = 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 Forvnt = aData(i, j)If IsNumeric(vnt) Then '是否数值If VarType(aData(i, j)) = 8 Then '是否文本strADS = strADS & "," & Cells(1, j + intFirstC - 1).AddressExit ForEnd IfEnd IfNextNextstrADS = 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) '数据存入结果数组NextEnd IfNext''建立新工作簿，存放结果数组Set wb = Workbooks.AddWith wb.Worksheets(1).Name = strName '命名If Err.Number Then '如果名称有特殊字符，则退出程序.Deletewb.Close FalseGoTo errDescriptEnd IfIf Len(strADS) Then.Range(strADS).EntireColumn.NumberFormat = "@" '特殊列设置为文本格式End IfWith .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 Withwb.SaveAs strPath & strNamewb.Close FalseNext
errDescript:shtAct.SelectCall reAppSet '恢复屏幕刷新等系统设置Set d = Nothing '释放字典内存If Err.Number ThenMsgBox Err.DescriptionElseMsgBox "拆分完成。"End If
End Sub'用户选择文件夹路径
Function getStrPath() As StringDim strPath As StringWith Application.FileDialog(msoFileDialogFolderPicker)If .Show ThenstrPath = .SelectedItems(1)Else '如用户为选中文件夹则退出Exit FunctionEnd IfEnd WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"getStrPath = strPath
End Function'获取用户输入的标题行数
Function getTitCount()Dim intTitCountintTitCount = InputBox("请输入标题行的行数", _Title:="公众号Excel星球", _Default:=1)If StrPtr(intTitCount) = False ThengetTitCount = FalseExit FunctionEnd IfIf IsNumeric(intTitCount) = False ThenMsgBox "标题行的行数只能输入数字。"getTitCount = FalseExit FunctionEnd IfIf intTitCount < 0 ThenMsgBox "标题行数不能为负数。"getTitCount = FalseExit FunctionEnd IfgetTitCount = intTitCount
End Function'用户选择拆分依据列
Function GetRngGistC() As RangeDim rngGistC As RangeSet rngGistC = Application.InputBox("请选择拆分依据列。", _Title:="公众号Excel星球", _Default:=Selection.Address, _Type:=8)If rngGistC Is Nothing ThenExit FunctionEnd IfIf rngGistC.Columns.Count > 1 ThenMsgBox "拆分依据列只能是单列。"Exit FunctionEnd IfSet GetRngGistC = rngGistC
End Function'取消屏幕刷新，公式重算等
Sub disAppSet()With Application.ScreenUpdating = False.Calculation = xlCalculationManual.DisplayAlerts = FalseEnd With
End Sub'恢复屏幕刷新等
Sub reAppSet()With Application.ScreenUpdating = True.Calculation = xlCalculationAutomatic.DisplayAlerts = TrueEnd 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 RangeDim strName As String, strPath As StringDim n As Long, y As Long, strErr As StringOn 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 '记录名称Elsey = y + 1 '记录正确创建工作簿的数量End IfActiveWorkbook.Close , False '关闭不保存End IfNextCall reAppSetIf n ThenMsgBox "有" & n & "张工作簿创建失败，原因是工作簿重名或格式错误。" & _"名单如下：" & vbCrLf & _Mid(strErr, 2)ElseIf y ThenMsgBox "创建完成。"End If
End SubSub disAppSet()With Application '取消屏幕刷新、信息警告、公式重算等.ScreenUpdating = False.DisplayAlerts = False.AskToUpdateLinks = False.Calculation = xlCalculationManualEnd With
End SubSub reAppSet()With Application '取消屏幕刷新、信息警告、公式重算等.ScreenUpdating = True.DisplayAlerts = True.AskToUpdateLinks = True.Calculation = xlCalculationAutomaticEnd With
End Sub'用户选择名称来源区域
Function getRngData() As RangeDim rngData As RangeSet rngData = Application.InputBox("请选择新建工作簿名称来源。", _Title:="提示", _Default:=Selection.Address, _Type:=8) '用户选择名称来源区域Set rngData = Intersect(rngData, rngData.Parent.UsedRange)'交集运算，避免用户选择整列数据造成运算量虚大或选择区域空白If rngData Is Nothing Then '如果用户关闭了对话框，或选择区域空白，则退出程序MsgBox "未选择有效区域。"Exit FunctionEnd IfSet 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 RangeDim strName As String, strPath As StringDim n As Long, y As Long, strErr As StringDim shtTemp As WorksheetOn Error Resume Next '忽略程序错误继续运行Set rngData = getRngData() '用户选择名单区域If Err.Number Then Exit Sub '如果选择无效区域则退出程序Set shtTemp = Worksheets("模板")If Err.Number ThenMsgBox "HI，没找到名为模板的工作簿，请核实。"Exit SubEnd IfCall 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 '记录名称Elsey = y + 1 '记录正确创建工作簿的数量End IfActiveWorkbook.Close , FalseEnd IfNextCall reAppSetIf n ThenMsgBox "有" & n & "张工作簿创建失败，原因是工作簿重名或格式错误。" & _"名单如下：" & vbCrLf & _Mid(strErr, 2)ElseIf y ThenMsgBox "创建完成。"End If
End SubSub disAppSet()With Application '取消屏幕刷新、信息警告、公式重算等.ScreenUpdating = False.DisplayAlerts = False.AskToUpdateLinks = False.Calculation = xlCalculationManualEnd With
End SubSub reAppSet()With Application '取消屏幕刷新、信息警告、公式重算等.ScreenUpdating = True.DisplayAlerts = True.AskToUpdateLinks = True.Calculation = xlCalculationAutomaticEnd With
End Sub'用户选择名称来源区域
Function getRngData() As RangeDim rngData As RangeSet rngData = Application.InputBox("请选择新建工作簿名称来源。", _Title:="提示", _Default:=Selection.Address, _Type:=8) '用户选择名称来源区域Set rngData = Intersect(rngData, rngData.Parent.UsedRange)'交集运算，避免用户选择整列数据造成运算量虚大或选择区域空白If rngData Is Nothing Then '如果用户关闭了对话框，或选择区域空白，则退出程序MsgBox "未选择有效区域。"Exit FunctionEnd IfSet getRngData = rngData
End Function

代码详细解释见注释……

打个响指，坦白的说，这段代码和上一期代码十分相似，简直是同父异母的哥俩好。第9行至第13行代码，指定名称为"模板"的工作表为新建工作簿的模板；如果当前工作簿查无此表，则退出程序。

第21行代码使用工作表的Copy方法复制一个工作表，但未指定复制后工作表的保存位置；我们上一章讲过，这种情况下，系统会将该工作表转换为活动工作簿。

第22行代码将活动工作簿保存到指定路径下。第23至28行代码判断工作簿名称是否符合规则。其余代码和上一节代码并无二样，也就不需赘言。

VBA按名单删除工作簿、定时自杀工作簿

1 丨删除工作簿

在「什么是工作簿」一章里咱们讲过，删除指定工作簿可以使用Kill语句，示例代码如下▼

Sub DelWB()    Dim strPath As String    strPath = ThisWorkbook.Path & "\公众号Excel星球.xlsx"    Kill strPath '删除End Sub

而如果需要删除指定文件夹下全部的工作簿，可以使用以下语句▼

Sub DelAllWorkBooks()    Dim strPath As String    strPath = ThisWorkbook.Path & "\测试\*.xls*"    Kill strPathEnd Sub

Kill语句可以从磁盘中删除指定文件，并支持使用通配符匹配文件名。第3行代码指定了文件夹的路径，以及需要删除的文件类型：*.xls*，其中*可以代替0到多个字符，也就代表了Excel各种类型的工作簿。

如果需要删除指定文件夹下的全部文件，代码如下▼

Sub DelAllFiles()    Dim strPath As String    strPath = 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, aResDim i As Long, strMSG As String, n As LongDim strPath As String, strName As StringOn Error Resume NextSet rngData = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)aData = rngData '数据存入数组ReDim aRes(1 To UBound(aData), 1 To 1) '结果数组Application.ScreenUpdating = FalsestrPath = getStrPath() '获取文件夹路径If strPath = "" Then Exit SubFor i = 2 To UBound(aData) '扣掉标题行遍历数组If aData(i, 2) = "删除" Then '如果B列标记删除strName = Dir(strPath & aData(i, 1))If strName <> "" Then '判断是否存在相关文件Err.ClearKill strPath & strName '删除文件If Err.Number Then '如果程序错误aRes(i, 1) = "删除失败"n = n + 1ElseaRes(i, 1) = "删除成功"End IfElseaRes(i, 1) = "查无文件"n = n + 1End IfEnd IfNextColumns(3).ClearContentsaRes(1, 1) = "处理结果"Range("c1").Resize(UBound(aRes, 1)) = aRes '处理结果写会ExcelApplication.ScreenUpdating = TruestrMSG = "处理完成。"If n Then strMSG = strMSG & vbCrLf & _"有" & n & "个文件删除失败," & _"需核对文件名、后缀或路径是否正确。"MsgBox strMSG
End Sub'用户选择文件夹
Function getStrPath() As StringDim strPath As StringWith Application.FileDialog(msoFileDialogFolderPicker)If .Show ThenstrPath = .SelectedItems(1)Else '如用户为选中文件夹则退出Exit FunctionEnd IfEnd WithIf 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 Datedat = DateSerial(2219, 10, 1) '自杀日期If Date >= dat ThenOn Error Resume NextApplication.DisplayAlerts = False '取消警告信息MsgBox "表生自古谁不死？留取担心找汉卿，走了你。"With ThisWorkbook.Saved = True '保存.ChangeFileAccess xlReadOnly '只读Kill .FullName '杀死自己.Close  '关闭不保存End WithApplication.DisplayAlerts = TrueEnd If
End Sub

第3行代码使用DateSerial函数指定一个日期，并赋值变量dat，第4行代码判断当前日期是否大于或等于dat，如果条件成立，则执行自杀计划。

第8行代码使用With语句引用代码所在工作簿对象。

第9行代码将该工作簿的Saved属性修改为True，为的是避免切换文件读写状态时出现系统警告信息对话框。

第10行代码使用ChangeFileAccess方法将工作簿的访问权限修改为只读。在只读状态下，Kill语句可以删除打开的工作簿，而不返回程序错误。

第11行代码使用工作簿的FullName属性返回代码所在工作簿的完整路径，然后使用Kill语句杀死它。

第12行代码关闭工作簿，盖木欧瓦。

需要汇总多工作簿数据到总表？一个模版一键搞定~

今天分享一段VBA代码，作用是将指定文件夹下全部excel或csv类型文件的数据汇总到当前工作表。照例代码复制即可使用，或者文末下载模版，点击按钮即可完成既定目标。

如何将指定文件夹下所有工作簿的工作表移动到当前工作簿？

牵牵爪子，一起看个小视频，了解下模版运行过程和效果。

如需实现以上动画展示的功能，示例代码如下▼

Sub GetSheetsCopy()Dim strPath As String, strBookName As String, strKey As StringDim strShtName As String, k As Long, wb As WorkbookDim sht As Worksheet, shtActive As WorksheetOn Error Resume NextWith Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strPath = .SelectedItems(1) Else: Exit SubEnd WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"strKey = InputBox("请输入工作表名称所包含的关键词。" & vbCr _& "关键词可以为空，如为空，则默认移动全部工作表")If StrPtr(strKey) = 0 Then Exit SubSet shtActive = ActiveSheet '当前工作表，代码运行完毕后，回到此表With Application.ScreenUpdating = False.DisplayAlerts = False.AskToUpdateLinks = False.Calculation = xlManualEnd WithstrBookName = Dir(strPath & "*.xls*")Do While strBookName <> ""If strBookName = ThisWorkbook.Name ThenMsgBox "注意：指定文件夹中存在和当前工作簿重名的工作簿！！" & vbCr & "该工作簿无法打开，工作表无法复制。" '当出现重名工作簿时，提醒用户。ElseSet wb = Workbooks.Open(strPath & strBookName)For Each sht In wb.WorksheetsIf IsEmpty(sht.UsedRange) = False ThenIf 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 IfEnd IfNextwb.Close False '关闭工作簿，不保存End IfstrBookName = Dir '下一个符合条件的文件LoopshtActive.Select '回到初始工作表MsgBox "工作表收集完毕，共收集：" & k & "个"With Application.ScreenUpdating = True.DisplayAlerts = True.AskToUpdateLinks = True.Calculation = xlAutomaticEnd With
End Sub

如何按相同工作表名称，批量汇总多工作簿数据到总表？

在实际工作中，我们也可能碰到下面这种情况：

每个工作簿包含数量不一、名称相同的工作表，在汇总数据时，需要按工作表名称分别汇总。比如，名为财务部的工作表单独汇总成一张工作表，名为销售部的也单独汇总成一张工作表……

动画演示如下：

打个响指，复制粘贴运行以下代码即可解决此类问题。


Sub GetEachShtData()Dim i As Long, intLastRow As LongDim shtSum As Worksheet, shtAct As Worksheet, shtData As WorksheetDim aFileName, wb As Workbook, d As ObjectDim strFileName As String, strPath As String, strShtName As StringOn Error Resume NextstrPath = getStrPath() '用户选择路径If strPath = "" Then Exit SubaFileName = GetWbFullNames(strPath) '获取文件名单If IsArray(aFileName) = False Then Exit SubCall 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 .WorksheetsIf shtData.FilterMode = True Then shtData.Cells.AutoFilter '取消筛选strShtName = shtData.Name '工作表名称If Not d.exists(strShtName) Thend(strShtName) = "" '工作表移动到代码所在工作簿shtData.Copy after:=wb.Worksheets(wb.Sheets.Count)ElseSet shtSum = wb.Worksheets(strShtName)intLastRow = GetLastRow(shtSum) + 1 '最后存在数据的行shtData.UsedRange.Copy shtSum.Cells(intLastRow, 1) '复制粘贴End IfNext.Close False '关闭不保存End WithNextCall reAppSet '恢复系统设置Set d = NothingshtAct.SelectIf Err.Number ThenMsgBox Err.DescriptionElseMsgBox "汇总完成。"End If
End Sub'用户选择文件夹路径
Function getStrPath() As StringDim strPath As StringWith Application.FileDialog(msoFileDialogFolderPicker)If .Show ThenstrPath = .SelectedItems(1)Else '如用户为选中文件夹则退出Exit FunctionEnd IfEnd WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"getStrPath = strPath
End Function'获取文件名名单
Function GetWbFullNames(strPath As String)Dim strShtName As String, strTemp As StringDim aRes(), k As Longk = 0strShtName = Dir(strPath & "*.*")Do While strShtName <> ""strTemp = Right(strShtName, 4)If strTemp Like "*xls*" Or strTemp Like "*csv*" Thenk = k + 1ReDim Preserve aRes(1 To k)aRes(k) = strPath & strShtNameEnd IfstrShtName = Dir()LoopGetWbFullNames = aRes
End Function'查询有效数据最大行
Function GetLastRow(shtData As Worksheet)GetLastRow = shtData.Cells.Find("*", _LookIn:=xlFormulas, SearchOrder:=xlByRows, _SearchDirection:=xlPrevious).Row
End FunctionSub delsht()Dim sht As WorksheetFor Each sht In ThisWorkbook.WorksheetsIf sht.Name <> ActiveSheet.Name Then sht.DeleteNext
End SubSub disAppSet() '撤销屏幕刷新With Application.ScreenUpdating = False.DisplayAlerts = False.EnableEvents = False.AskToUpdateLinks = False.Calculation = xlCalculationManualEnd With
End SubSub reAppSet() '恢复屏幕刷新等With Application.ScreenUpdating = True.DisplayAlerts = True.EnableEvents = True.AskToUpdateLinks = True.Calculation = xlCalculationAutomaticEnd 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 StringDim k As LongstrPath = getStrPath() '获取用户选中文件夹的路径If strPath = "" Then Exit Sub '如果用户为选择文件夹，则退出程序Application.ScreenUpdating = FalseWith ActiveSheet.Columns(1).Clear '清空A列.NumberFormat = "@" '设置文本格式End Withk = 1Cells(k, 1) = "目录"strName = Dir(strPath & "*.*")Do While strName <> ""k = k + 1 '计数器Cells(k, 1) = strNamestrName = Dir() '第2次调用dir函数但未带参数LoopApplication.ScreenUpdating = TrueMsgBox "OK"
End Sub
Function getStrPath() As StringDim strPath As StringWith Application.FileDialog(msoFileDialogFolderPicker)If .Show ThenstrPath = .SelectedItems(1)Else '如用户为选中文件夹则退出Exit FunctionEnd IfEnd WithIf 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函数的特点，它会查找同目录下的下一个文件名。