17.Excel：实用的 VBA 自动化程序

一 excel 设置

开始-选项

二 批量创建工作表

某工作簿用于保存31天的东西，手动创建31个工作表不方便。

A1单元格输入内容，或者空着。从A2单元格开始，一定要以字符形式的，不能以数值和日期形式。12345这是数值形式，1月1日这样是日期形式，日期形式的本质仍然是数值。1900年1月1日是1。想输入数值和日期，打1个英文的单引号。

然后下拉列表。

 

Sub NewSht()Dim shtActive As Worksheet, sht As WorksheetDim i As Long, strShtName As StringOn Error Resume Next '当代码出错时继续运行Set shtActive = ActiveSheetFor i = 2 To shtActive.Cells(Rows.Count, 1).End(xlUp).Row'单元格A1是标题，跳过，从第2行开始遍历工作表名称strShtName = shtActive.Cells(i, 1).Value'工作表名强制转换为字符串类型Set sht = Sheets(strShtName)'当工作簿不存在工作表Sheets(strShtName)时，这句代码会出错，然后……If Err Then'如果代码出错，说明不存在工作表Sheets(t)，则新建工作表Worksheets.Add , Sheets(Sheets.Count)'新建一个工作表，位置放在所有已存在工作表的后面ActiveSheet.Name = strShtName'新建的工作表必然是活动工作表，为之命名Err.Clear'清除错误状态End IfNextshtActive.Activate'重新激活原工作表
End Sub

 

三 删除工作表只保留最后一张

把要保存的工作表放在所有工作表的最后面，代码只保存最后一张工作表。

Sub DelShet() '删除所有工作表Dim sht As WorksheetApplication.ScreenUpdating = False '关屏幕刷新Application.DisplayAlerts = False '关警告信息On Error Resume NextFor Each sht In Worksheetssht.Delete '遍历工作表删除NextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

四 提取所有工作表的名字到一个工作表中

1.运行结果有两列

补充：搭配五使用。

Sub GetShtByVba()Dim sht As Worksheet, k As LongApplication.ScreenUpdating = Falsek = 1Range("a:b").Clear '清空数据Range("a:a").NumberFormat = "@" '设置文本格式For Each sht In Worksheets '遍历工作表取表名k = k + 1Cells(k, 1) = sht.NameNextRange("a1:b1") = Array("工作表名", "是否删除")Application.ScreenUpdating = True
End Sub

2.运行结果只有一列

补充：结合八使用。

第1列有东西，会覆盖清除第1列。

Sub GetShtName()Dim sht As Worksheet, i As Longi = 1 'i初始值为1With Columns(1).ClearContents '清除A列内容.NumberFormat = "@" '设置单元格格式为文本End WithCells(1, 1) = "工作表名称目录"For Each sht In Worksheets '遍历工作表i = i + 1Cells(i, 1) = sht.Name '在A列记录工作表名称Next
End Sub

运行结果：

总表是因为有一张表的名称叫做总表。 

五 删除指定名字的工作表

补充：结合四.1使用

在要删除表的后面写删除。

Sub DelShtByVba()Dim sht As Worksheet, i As Long, rApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume Nextr = Range("a1").CurrentRegion '数据装入数组rFor i = 2 To UBound(r) '遍历并删除工作表If r(i, 2) = "删除" Then Worksheets(CStr(r(i, 1))).DeleteNextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

 2，5，8没有了。

六 如何生成带超链接的工作表目录

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.NameIf strShtName <> ActiveSheet.Name Then'如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接i = i + 1 '累加工作表数量ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _SubAddress:="'" & strShtName & "'!a1", TextToDisplay:=strShtName'建超链接End IfNext
End Sub

粘贴完代码后，选择要插入目录的工作表。

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

点完1月7日就到1月7日的工作表中了，但是想到别的表中又要回到sheet1这个工作表中来跳转，很不方便。想要有一个返回到总表的按钮。

Dim strShtName As String
Sub Mybutton()Dim sht As Worksheet, btn As ButtonOn Error Resume NextFor Each sht In WorksheetsWith shtIf .Name <> strShtName Then.Shapes(strShtName).Delete'删除原有的名称为shtn的按钮，避免重复创建Set btn = .Buttons.Add(0, 0, 60, 30)'使用add方法在工作表中添加一个按钮控件，add方法语法如下:表达式.Add(left,right,width,height)'新建按钮，释义见小贴士With btn.Name = strShtName'命令按钮命名.Characters.Text = "返回总表"'按钮的文本内容.OnAction = "LinkTable"'指定按钮控件所执行的宏命令End WithEnd IfEnd WithNextSet btn = Nothing
End SubSub LinkTable()strShtName = "总表"'指定了返回总表的名字，可以根据实际需要修改为目标表的名称，比如“目录”。'设置变量strShtName为总表的名称，可以根据实际总表的名称做修改Worksheets(strShtName).Activate[a1].Select
End Sub

右键剪切，然后粘贴，可以粘到想要的位置。

八 批量修改工作表的名字

补充：结合四.2使用。

修改制定工作表的名字，在B列对应位置写新名字即可，先打英文的引号再写，日期和数值型。

总表是第一张工作表的名称叫总表。

Sub ReNameSht()Dim strShtName$, sht As Worksheet, i&On Error Resume Next '当程序运行中出现错误时，继续运行For i = 2 To Cells(Rows.Count, 1).End(xlup).Row '遍历当前表格A列的数据strShtName = Cells(i, 1).Value '将表格A列的值，赋予变量strShtNameWorksheets(strShtName).Name = Cells(i, 2).Value '工作表重命名Next
End Sub

九 批量取消工作表的隐藏

Sub unShtVisible()Dim sht As WorksheetFor Each sht In Worksheets '遍历工作表，设置可见sht.Visible = xlSheetVisibleNext
End Sub

补充：新版本的excel可以直接取消隐藏了。 

十 汇总多个工作表到一张表中

1.不带格式的汇总

Sub CollectData()Dim Sht As Worksheet, rng As Range, k&, n&Application.ScreenUpdating = False'取消屏幕更新n = Val(InputBox("请输入标题的行数", "提醒"))If n < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub'取得用户输入的标题行数，如果为负数，退出程序Cells.ClearContents'清空当前表数据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(n).CopyCells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValuesEnd IfEnd IfNext[a1].ActivateApplication.ScreenUpdating = True '恢复屏幕刷新
End Sub

如果每个分表是多行标题，比如2，那就输入2

这里输入1

补充：Excel多行标题举例。

2.带格式的汇总

Sub CollectDataFromShtFormat()Dim sht As Worksheet, rng As Range, k As Long, nTitleCount As LongOn Error Resume NextnTitleCount = Val(InputBox("请输入标题的行数", "提醒", 1))If nTitleCount < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit SubApplication.ScreenUpdating = FalseCells.ClearContents '清空当前表数据For Each sht In Worksheets '遍历工作表If sht.Name <> ActiveSheet.Name Then'如果工作表名称不等于当前表名则进行汇总动作……Set rng = sht.UsedRangek = k + 1 '累计K值If k = 1 Then '如果是首个表格，则K为1，则把标题行一起复制到汇总表sht.Cells.Copy: Range("a1").PasteSpecial Paste:=xlPasteFormats '只粘贴格式rng.Copy: Range("a1").PasteSpecial Paste:=xlPasteValues '只粘贴数值Else '否则，扣除标题行后再复制黏贴到总表，只黏贴数值rng.Offset(nTitleCount).CopyWith Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteFormats '粘贴格式.PasteSpecial Paste:=xlPasteValues '粘贴数值End WithEnd IfEnd IfNextRange("a1").ActivateApplication.ScreenUpdating = True '恢复屏幕刷新MsgBox "汇总OK，一共汇总了：" & k & "张工作表"
End Sub

十一 对工作表进行批量排序 

第1步：提取工作表名字

Sub GetShtName()Dim k As Long, sht As WorksheetApplication.ScreenUpdating = FalseWith Columns(1).ClearContents '清空A列原有数据.NumberFormat = "@" '设置单元格格式为文本End WithCells(1, 1) = "目录"k = 1For Each sht In ThisWorkbook.Worksheets '遍历工作表If sht.Name <> ActiveSheet.Name Then '如果sht不等于当前工作表名称k = k + 1 '累加工作表个数Cells(k, 1) = sht.Name '工作表名称写入A列End IfNextApplication.ScreenUpdating = True
End Sub

第2步：排序 

升序或者降序排序，或者自定义。

更改顺序：

Sub SortSht()Dim shtActive As Worksheet, i As LongDim arr, strShtName As StringOn Error Resume NextApplication.ScreenUpdating = FalseSet shtActive = ActiveSheet '当前表赋值变量shtactivearr = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)'A列数据装入数组arrFor i = 2 To UBound(arr) '遍历数组arrstrShtName = arr(i, 1)Worksheets(strShtName).Move after:=Worksheets(i - 1)'指定工作表按顺序排放NextshtActive.Select '回到操作表Application.ScreenUpdating = True
End Sub

十二 批量工作表加密和解密

1.加密

只能看工作表不能修改工作表，可以复制。

补充：工作簿加密是看都看不到，要输入密码才能看。

想给这四个工作表都加密。

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

2.解密

Sub UnProtct()MsgBox "破解提示：当要求输入密码时请点击取消！”"Application.DisplayAlerts = FalseOn Error Resume NextDim sht As WorksheetFor Each sht In WorksheetsWith sht.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True.Protect DrawingObjects:=True, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True.UnprotectEnd WithNextMsgBox "ok"
End Sub

十三 按任意列拆分多个表

给了一个总表，想把客服的所有数据新建一个工作表，粘贴进去，或者1月的一个表，2月的一个表，重复的复制粘贴很麻烦。

Sub SplitShts()Dim d As Object, sht As WorksheetDim aData, aResult, aTemp, aKeys, i&, j&, k&, x&Dim rngData As Range, rngGist As RangeDim lngTitleCount&, lngGistCol&, lngColCount&Dim rngFormat As Range, aRef, strYesOrNo As StringDim strKey As String, strTemp As StringOn Error Resume Next '忽略错误，程序继续运行Set d = CreateObject("scripting.dictionary")Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)'用户选择的拆分依据列lngGistCol = rngGist.Column'拆分依据列的列标lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", Default:=1))'用户设置总表的标题行数If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit SubstrYesOrNo = MsgBox("是否需要在分表保留总表格式？", vbYesNo)Set rngData = rngGist.Parent.UsedRange'总表的数据区域Set rngFormat = rngGist.Parent.Cells'总表的单元格区域用于粘贴总表格式aData = rngData.Value '数据源装入数组lngGistCol = lngGistCol - rngData.Column + 1'计算依据列在数组中的位置lngColCount = UBound(aData, 2)'数据源的列数Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseReDim aRef(1 To UBound(aData))For i = 1 To UBound(aData) '处理依据列的异常值，空白/错误值/整行空白等If IsError(aData(i, lngGistCol)) ThenaRef(i) = "错误值"ElseIf aData(i, lngGistCol) = "" ThenstrTemp = "" '判断是否整行数据为空For j = 1 To lngColCountstrTemp = strTemp & aData(i, j)NextIf strTemp = "" Then '如果整行为空aRef(i) = "整行空白"ElseaRef(i) = "空白单元格"End IfElsestrKey = aData(i, lngGistCol)aRef(i) = strKeyEnd IfNextFor i = lngTitleCount + 1 To UBound(aData)strKey = aRef(i)If strKey <> "整行空白" ThenIf Not d.exists(strKey) Then'字典中不存在关键字时则遍历建表d(strKey) = ""ReDim aResult(1 To UBound(aData), 1 To lngColCount) '声明一个结果数组k = 0For x = lngTitleCount + 1 To UBound(aData) '遍历数据源strTemp = aRef(x)If strTemp = strKey Then '如果记录符合条件，则装入结果数组k = k + 1For j = 1 To lngColCountaResult(k, j) = aData(x, j)NextEnd IfNextFor Each sht In ActiveWorkbook.Worksheets '删除旧表If sht.Name = strKey Then sht.DeleteNextWith Worksheets.Add(, Sheets(Sheets.Count))'新建一个工作表.Name = strKey.Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"'设置单元格为文本格式If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData'标题行.Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult'写入数据If strYesOrNo = vbYes Then '如果用户选择保留总表格式rngFormat.Copy.Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False'复制粘贴总表的格式.Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete'删除多余的格式单元格End If.Range("a1").SelectEnd WithEnd IfEnd IfNextrngData.Parent.Activate '回到总表Application.ScreenUpdating = TrueApplication.DisplayAlerts = TrueSet d = NothingSet rngData = NothingSet rngGist = NothingSet rngFormat = NothingErase aData: Erase aResultMsgBox "数据拆分完成！"
End Sub

说明按照哪列来拆分，以哪列来作为表名字。 

比如加粗，加黑，颜色。 

十四 批量将工作表转换为独立的工作簿

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

十五 将总表按任意列拆分成多个工作簿

比如按照部门保存成不同的工作簿。

之前是按列分成不同的工作表，然后再进行保存，现在可以一步到位。

Sub SplitShts()Dim d As Object, sht As WorksheetDim aData, aResult, aTemp, aKeys, i&, j&, k&, x&Dim rngData As Range, rngGist As Range, ws As WorkbookDim lngTitleCount&, lngGistCol&, lngColCount&Dim rngFormat As Range, aRef, strYesOrNo As StringDim strKey As String, strTemp As String, strPath As StringOn Error Resume Next '忽略错误，程序继续运行Set d = CreateObject("scripting.dictionary")With Application.FileDialog(msoFileDialogFolderPicker)'用户选择保存工作簿的路径If .Show Then strPath = .SelectedItems(1) Else Exit SubEnd WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)'用户选择的拆分依据列If rngGist Is Nothing Then Exit SublngGistCol = rngGist.Column '拆分依据列的列标lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", Default:=1))'用户设置总表的标题行数If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit SubstrYesOrNo = MsgBox("是否需要在分表保留总表格式？", vbYesNo)Set rngData = rngGist.Parent.UsedRange'总表的数据区域Set rngFormat = rngGist.Parent.Cells'总表的单元格区域用于粘贴总表格式aData = rngData.Value '数据源装入数组lngGistCol = lngGistCol - rngData.Column + 1'计算依据列在数组中的位置lngColCount = UBound(aData, 2)'数据源的列数Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseReDim aRef(1 To UBound(aData))For i = 1 To UBound(aData) '处理依据列的异常值，空白/错误值/整行空白等If IsError(aData(i, lngGistCol)) ThenaRef(i) = "错误值"ElseIf aData(i, lngGistCol) = "" ThenstrTemp = "" '判断是否整行数据为空For j = 1 To lngColCountstrTemp = strTemp & aData(i, j)NextIf strTemp = "" Then '如果整行为空aRef(i) = "整行空白"ElseaRef(i) = "空白单元格"End IfElsestrKey = aData(i, lngGistCol)aRef(i) = strKeyEnd IfNextFor i = lngTitleCount + 1 To UBound(aData)strKey = aRef(i)If strKey <> "整行空白" ThenIf Not d.exists(strKey) Then'字典中不存在关键字时则遍历建表d(strKey) = ""ReDim aResult(1 To UBound(aData), 1 To lngColCount) '声明一个结果数组k = 0For x = lngTitleCount + 1 To UBound(aData) '遍历数据源strTemp = aRef(x)If strTemp = strKey Then '如果记录符合条件，则装入结果数组k = k + 1For j = 1 To lngColCountaResult(k, j) = aData(x, j)NextEnd IfNextSet ws = Workbooks.AddWith ws.Sheets(1)'新建一个工作簿.Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"'设置单元格为文本格式If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData'标题行.Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult'写入数据If strYesOrNo = vbYes Then '如果用户选择保留总表格式rngFormat.Copy.Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False'复制粘贴总表的格式.Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete'删除多余的格式单元格End If.Range("a1").SelectEnd Withws.SaveAs strPath & strKey, xlWorkbookDefaultws.Close FalseEnd IfEnd IfNextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueSet d = NothingSet rngData = NothingSet rngGist = NothingSet rngFormat = NothingErase aData: Erase aResultMsgBox "数据拆分完成！"
End Sub

 十六 选中行或列会填充颜色

点这个格子这一行都会填色，方便看数据。

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Application.ScreenUpdating = FalseCells.Interior.ColorIndex = -4142 '取消单元格原有填充色，但不包含条件格式产生的颜色。Rows(Target.Row).Interior.ColorIndex = 33 '活动单元格整行填充颜色Columns(Target.Column).Interior.ColorIndex = 33 '活动单元格整列填充颜色Application.ScreenUpdating = True
End Sub

写完代码后关掉即可。 

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

把要创建工作簿的名称写在A列，从A2单元格开始写，A1单元格写什么都不会创建。

Sub CreateFiles()Dim strPath As String, strFileName As StringDim i As Long, rOn Error Resume NextWith Application.FileDialog(msoFileDialogFolderPicker)'用户选择文件夹路径If .Show Then strPath = .SelectedItems(1) Else Exit Sub'如果用户为选择文件夹则退出程序End WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"Application.ScreenUpdating = False '取消屏幕刷新Application.DisplayAlerts = False '取消警告提示，当有重名工作簿时直接覆盖r = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row) '数据装入数组rFor i = 2 To UBound(r) '标题不要，因此从第2个元素开始遍历数组rWith Workbooks.Add '新建工作簿.SaveAs strPath & r(i, 1), xlWorkbookDefault'以指定名称、默认文件类型保存工作簿.Close True '关闭工作簿End WithNextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueMsgBox "创建完成。"
End Sub

十八 按指定条件批量删除工作簿

第1步

随便打开一个新的Excel文件。

Sub GetFiles()Dim strPath As String, strFileName As String, k As LongWith Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strPath = .SelectedItems(1) Else: Exit Sub'获取用户选择的文件夹的路径，如果未选取，则退出程序End WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"Application.ScreenUpdating = FalseRange("a:b").Clear: k = 1'清除A:B列的所有Cells(1, 1) = "旧文件名": Cells(1, 2) = "是否删除"strFileName = Dir(strPath & "*.xls*")Do While strFileName <> ""k = k + 1Cells(k, 1) = strPath & strFileNamestrFileName = DirLoopApplication.DisplayAlerts = True
End Sub

第2步

写删除。

Sub DeleteFile()Dim r, i As Longr = Range("a1").CurrentRegion '数据装入数组For i = 2 To UBound(r)'标题行不要，从数组第二行开始遍历If r(i, 2) = "删除" Then Kill r(i, 1) 'Kill语句删除指定文件NextMsgBox "完成。"
End Sub

 十九 批量获取指定文件夹下文件名并创建超链接

把某个文件夹下面的文件，做一个带超链接的Excel目录，Excel一点就可以打开这个文件。

打开一个Excel空白文档。

Sub GetFiles()Dim strPath As String, strFileName As String, k As LongWith Application.FileDialog(msoFileDialogFolderPicker)'用户选择文件夹路径If .Show Then strPath = .SelectedItems(1) Else Exit Sub'如果用户为选择文件夹则退出程序End WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"Application.ScreenUpdating = False '取消屏幕刷新strFileName = Dir(strPath & "*.*")'dir+通配符获取首个文件名'如果一个文件也无，则返回空Columns(1).Clear: Cells(1, 1) = "目录": k = 1 '清除当前工作表A列数据Do While strFileName <> ""k = k + 1 '累加文件个数ActiveSheet.Hyperlinks.Add Cells(k, 1), strPath & strFileName'创建超链接strFileName = Dir'第2次调用Dir函数，未使用任何参数，则同目录下的下一个文件名LoopApplication.ScreenUpdating = TrueMsgBox "一共读取了：" & k-1 & "个文件名。"
End Sub

二十 批量给工作簿重命名

给某个文件夹下面所有文档重命名，只能做Excel文档，不能改格式。

第1步

打开一个新的Excel文件。

Sub GetFiles()Dim strPath As String, strFileName As String, k As LongWith Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strPath = .SelectedItems(1) Else: Exit Sub'获取用户选择的文件夹的路径，如果未选取，则退出程序End WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"Application.ScreenUpdating = FalseRange("a:b").Clear: k = 1'清除A:B列的所有Cells(1, 1) = "旧文件名": Cells(1, 2) = "新文件名"strFileName = Dir(strPath & "*.xls*")Do While strFileName <> ""k = k + 1Cells(k, 1) = strPath & strFileNamestrFileName = DirLoopApplication.DisplayAlerts = True
End Sub

先复制过来，然后再修改。

第2步

Sub ChangeFileName()Dim r, i As Longr = Range("a1").CurrentRegion '数据装入数组For i = 2 To UBound(r)'标题行不要，从数组第二行开始遍历Name r(i, 1) As r(i, 2) 'Name语句重命名NextMsgBox "更名完成。"
End Sub

 二十一 文档自杀

重要文档的密码可以破解，不安全。

注意保存格式。

Private Sub Workbook_Open()Dim dat As Datedat = DateSerial(2020, 1, 1)If Date >= dat ThenApplication.DisplayAlerts = FalseMsgBox "你是在偷看我的文件吗？" & vbCr & "别以为我不知道，我就在你身后看着你！白衣服，长头发，没有腿的那个。"With ThisWorkbook.Saved = True.ChangeFileAccess xlReadOnlyKill .FullName.CloseEnd WithEnd If
End Sub

然后关闭，不用运行。然后保存Excel工作簿。

打开文件，关闭后文件自己就没了。

 二十二 获取多层文件夹下文件名并创建超链接

每个文件夹下面有文件和文件夹，想在excel里面做一个超链接目录。

打开一个Excel空白文档。

Sub AutoAddLink()Dim strFldPath As StringWith Application.FileDialog(msoFileDialogFolderPicker)'用户选择指定文件夹.Title = "请选择指定文件夹。"If .Show Then strFldPath = .SelectedItems(1) Else Exit Sub'未选择文件夹则退出程序，否则将地址赋予变量strFldPathEnd WithApplication.ScreenUpdating = False'关闭屏幕刷新Range("a:b").ClearContentsRange("a1:b1") = Array("文件夹", "文件名")Call SearchFileToHyperlinks(strFldPath)'调取自定义函数SearchFileToHyperlinksRange("a:b").EntireColumn.AutoFit'自动列宽Application.ScreenUpdating = True'重开屏幕刷新
End Sub
Function SearchFileToHyperlinks(ByVal strFldPath As String) As StringDim objFld As ObjectDim objFile As ObjectDim objSubFld As ObjectDim strFilePath As StringDim lngLastRow As LongDim intNum As IntegerSet objFld = CreateObject("Scripting.FileSystemObject").GetFolder(strFldPath)'创建FileSystemObject对象引用For Each objFile In objFld.Files'遍历文件夹内的文件lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1strFilePath = objFile.PathintNum = InStrRev(strFilePath, "\")'使用instrrev函数获取最后文件夹名截至的位置Cells(lngLastRow, 1) = Left(strFilePath, intNum - 1)'文件夹地址Cells(lngLastRow, 2) = Mid(strFilePath, intNum + 1)'文件名ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngLastRow, 2), _Address:=strFilePath, ScreenTip:=strFilePath'添加超链接Next objFileFor Each objSubFld In objFld.SubFolders'遍历文件夹内的子文件夹Call SearchFileToHyperlinks(objSubFld.Path)Next objSubFldSet objFld = NothingSet objFile = NothingSet objSubFld = Nothing
End Function

选择文件夹。

 

二十三 合并多工作簿数据成总表 

一个文件夹里面有多个工作簿，里面有多个工作表。

字段名要一样，不然合并会出错。

打开一个空白Excel文档。

Sub CollectWorkBookDatas()Dim shtActive As Worksheet, rng As Range, shtData As WorksheetDim nTitleRow As Long, k As Long, nLastRow As LongDim i As Long, j As Long, nStartRow As LongDim aData, aResult, nStarRng As LongDim strPath As String, strFileName As StringDim strKey As String, nShtCount As LongWith Application.FileDialog(msoFileDialogFolderPicker)'取得用户选择的文件夹路径If .Show Then strPath = .SelectedItems(1) Else Exit SubEnd WithIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"strKey = InputBox("请输入需要合并的工作表所包含的关键词：" & vbCrLf & "如未填写关键词，则默认汇总全部表格数据", "提醒")If StrPtr(strKey) = 0 Then Exit Sub '如果点击了取消或者关闭按钮，则退出程序nTitleRow = Val(InputBox("请输入标题的行数，默认标题行数为1", "提醒", 1))If nTitleRow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit SubSet shtActive = ActiveSheetWith Application.ScreenUpdating = False.DisplayAlerts = False.AskToUpdateLinks = FalseEnd WithReDim aResult(1 To 80000, 1 To 1) '声明结果数组Cells.ClearContents '清空当前表格数据Cells.NumberFormat = "@" '设置单元格为文本格式strFileName = Dir(strPath & "*.xls*") '使用Dir函数遍历excel文件Do While strFileName <> ""If strFileName <> ThisWorkbook.Name Then '避免同名文件重复打开出错With GetObject(strPath & strFileName)'以只读'形式读取文件时，使用getobject会比workbooks.open稍快For Each shtData In .Worksheets '遍历表If InStr(1, shtData.Name, strKey, vbTextCompare) Then'如果表中包含关键字则进行汇总(不区分关键词字母大小写）Set rng = shtData.UsedRangeIf rng.Count > 1 Then '判断工作表是否存在数据……nShtCount = nShtCount + 1 '汇总工作表的数量nStartRow = IIf(nShtCount = 1, 1, nTitleRow + 1) '判断遍历数据源是否应该扣掉标题行aData = rng.Value '数据区域读入数组arrIf UBound(aData, 2) + 2 > UBound(aResult, 2) Then '动态调整结果数组brr的最大列数ReDim Preserve aResult(1 To UBound(aResult), 1 To UBound(aData, 2) + 2)End IfFor i = nStartRow To UBound(aData) '遍历行k = k + 1aResult(k, 1) = strFileName '数组第一列放工作簿名称aResult(k, 2) = shtData.Name '数组第二列放工作表名称For j = 1 To UBound(aData, 2) '遍历列aResult(k, j + 2) = aData(i, j)NextIf k > UBound(aResult) - 1 Then'如果数据行数到达结果数组的上限，则将数据导入汇总表，并清空结果数组With shtActivenLastRow = .Cells(Rows.Count, 1).End(xlUp).Row '获取放置来源数据的位置If nLastRow = 1 Then '判断是否扣除标题行nStarRng = IIf(nTitleRow = 0, 1, 0).Range("a1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResult.Range("a1:b1") = Array("来源工作簿名称", "来源工作表名称")'前两列放来源工作簿和工作表名称Else.Range("a1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResult'放结果数组的数据End IfEnd Withk = 0ReDim aResult(1 To UBound(aResult), 1 To UBound(aResult, 2))'重新设置结果数组End IfNextEnd IfEnd IfNext.Close False '关闭工作簿End WithEnd IfstrFileName = Dir '下一个excel文件LoopIf k > 0 ThenshtActive.Select '激活汇总表nLastRow = Cells(Rows.Count, 1).End(xlUp).Row '放置数据的位置If nLastRow = 1 Then '如果汇总表数据为空，说明需要汇总的数据没有超过结果数组的上限nStarRng = IIf(nTitleRow = 0, 1, 0)Range("a1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResultRange("a1:b1") = Array("来源工作簿名称", "来源工作表名称")ElseRange("a1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResultEnd IfEnd IfWith Application.ScreenUpdating = True.DisplayAlerts = True.AskToUpdateLinks = TrueEnd WithMsgBox "一共汇总完成。" & nShtCount & "个工作表", , "孙兴华"
End Sub

一般是全合并，如果要关键词就逗号隔开。 

二十四 将Word表格批量写入Excel

程序运行比较慢，因为要遍历。

word文档里面插入表格，填了东西。文档里面有若干表格，一个个复制到Excel里面很麻烦。

Sub GetWordTable()Dim WdApp As ObjectDim objTable As ObjectDim objDoc As ObjectDim strPath As StringDim shtEach As WorksheetDim shtSelect As WorksheetDim i As LongDim j As LongDim x As LongDim y As LongDim k As LongDim brr As VariantSet WdApp = CreateObject("Word.Application")With Application.FileDialog(msoFileDialogFilePicker).Filters.Add "Word文件", "*.doc*", 1'只显示word文件.AllowMultiSelect = False'禁止多选文件If .Show Then strPath = .SelectedItems(1) Else Exit SubEnd WithApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet shtSelect = ActiveSheet'当前表赋值变量shtSelect，方便代码运行完成后叶落归根回到开始的地方For Each shtEach In Worksheets'删除当前工作表以外的所有工作表If shtEach.Name <> shtSelect.Name Then shtEach.DeleteNextshtSelect.Name = "孙兴华"'这句代码不是无聊，作用在于……你猜……'……其实是避免下面的程序工作表名称重复Set objDoc = WdApp.documents.Open(strPath)'后台打开用户选定的word文档For Each objTable In objDoc.tables'遍历文档中的每个表格k = k + 1Worksheets.Add after:=Worksheets(Worksheets.Count)'新建工作表ActiveSheet.Name = k & "表"x = objTable.Rows.Count'table的行数y = objTable.Columns.Count'table的列数ReDim brr(1 To x, 1 To y)'以下遍历行列，数据写入数组brrFor i = 1 To xFor j = 1 To ybrr(i, j) = "'" & Application.Clean(objTable.cell(i, j).Range.Text)'Clean函数清除制表符等'半角单引号将数据统一转换为文本格式，避免身份证等数值变形NextNextWith [a1].Resize(x, y).Value = brr'数据写入Excel工作表.Borders.LineStyle = 1'添加边框线End WithNextshtSelect.SelectobjDoc.Close: WdApp.QuitApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueSet objDoc = NothingSet WdApp = NothingMsgBox "共获取：" & k & "张表格的数据。"
End Sub

打开一个空白的Excel文档，插入模块。找到word文档。

二十五 批量取消复杂单元格

Sub UnMergeRange2() '取消合并单元格
Dim MaxRow As Integer '
Dim Rng As Range
Dim x%, y%, m%, n%, i%
Dim Rng2 As RangeOn Error Resume NextSet Rng = Application.InputBox("请选择需要取消合并单元格的区域：", _"区域选择", , , , , , 8)For x = 1 To Rng.Rows.CountFor y = 1 To Rng.Columns.CountSet Rng2 = Rng.Cells(x, y)i = Rng2.MergeArea.CountIf i > 1 Thenm = Rng2.MergeArea.Rows.Countn = Rng2.MergeArea.Columns.CountRng2.UnMerge '取消合并单元格Rng2.Resize(m, n).Value = Rng2.ValueEnd IfNextNextEnd Sub

二十六 批量将图片插入到单元格批注中

把图片批量插到指定单元格的备注中。

Sub AddCommentPic()Dim arr, i&, k&, n&, b As BooleanDim strPicName$, strPicPath$, strFdPath$Dim rngData As Range, rngEach As Range'On Error Resume Next'用户选择图片所在的文件夹With Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strFdPath = .SelectedItems(1) Else: Exit SubEnd WithIf Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"Set rngData = Application.InputBox("请选择需要插入图片到批注中的单元格区域", Type:=8)'用户选择需要插入图片到批注中的单元格或区域If rngData.Count = 0 Then Exit SubSet rngData = Intersect(rngData.Parent.UsedRange, rngData)'intersect语句避免用户选择整列单元格，造成无谓运算的情况If rngData Is Nothing Then MsgBox "选择单元格不能全为空。": Exit Subarr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")'用数组变量记录五种文件格式Application.ScreenUpdating = FalseFor Each rngEach In rngData'遍历选择区域的每一个单元格If Not rngEach.Comment Is Nothing Then rngEach.Comment.Delete  '删除旧的批注strPicName = rngEach.Text '图片名称If Len(strPicName) Then '如果单元格存在值strPicPath = strFdPath & strPicName '图片路径b = False 'pd变量标记是否找到相关图片For i = 0 To UBound(arr)'由于不确定用户的图片格式，因此遍历图片格式If Len(Dir(strPicPath & arr(i))) Then'如果存在相关文件rngEach.AddComment '增加批注With rngEach.Comment.Visible = True '批注可见.Text Text:="".Shape.Select True '选中批注图形Selection.ShapeRange.Fill.UserPicture strPicPath & arr(i)'插入图片到批注中.Shape.Height = 150 '图形的高度，可以根据需要自己调整.Shape.Width = 150 '图形的宽度，可以根据需要自己调整.Visible = False '取消显示End Withb = True '标记找到结果n = n + 1 '累加找到结果的个数Exit For '找到结果后就可以退出文件格式循环End IfNextIf b = False Then k = k + 1  '如果没找到图片累加个数End IfNextMsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"Application.ScreenUpdating = True
End Sub

 

 

二十七 如何批量插入图片到表格中

Sub InsertPic()Dim arr, i&, k&, n&, b As BooleanDim strPicName$, strPicPath$, strFdPath$, shp As ShapeDim rngData As Range, rngEach As Range, rngWhere As Range, strWhere As String'On Error Resume Next'用户选择图片所在的文件夹With Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strFdPath = .SelectedItems(1) Else: Exit SubEnd WithIf Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"Set rngData = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)'用户选择需要插入图片的名称所在单元格范围Set rngData = Intersect(rngData.Parent.UsedRange, rngData)'intersect语句避免用户选择整列单元格，造成无谓运算的情况If rngData Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit SubstrWhere = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1")'用户输入图片相对单元格的偏移位置。If Len(strWhere) = 0 Then Exit Subx = Left(strWhere, 1)'偏移的方向If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Suby = Val(Mid(strWhere, 2))'偏移的值Select Case xCase "上"Set rngWhere = rngData.Offset(-y, 0)Case "下"Set rngWhere = rngData.Offset(y, 0)Case "左"Set rngWhere = rngData.Offset(0, -y)Case "右"Set rngWhere = rngData.Offset(0, y)End SelectApplication.ScreenUpdating = FalserngData.Parent.Parent.Activate '用户选定的激活工作簿rngData.Parent.SelectFor Each shp In ActiveSheet.Shapes'如果旧图片存放在目标图片存放范围则删除If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.DeleteNextx = rngWhere.Row - rngData.Rowy = rngWhere.Column - rngData.Column'偏移的坐标arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")'用数组变量记录五种文件格式For Each rngEach In rngData'遍历选择区域的每一个单元格strPicName = rngEach.Text'图片名称If Len(strPicName) Then'如果单元格存在值strPicPath = strFdPath & strPicName'图片路径b = False'变量标记是否找到相关图片For i = 0 To UBound(arr)'由于不确定用户的图片格式，因此遍历图片格式If Len(Dir(strPicPath & arr(i))) Then'如果存在相关文件Set shp = ActiveSheet.Shapes.AddPicture( _strPicPath & arr(i), False, True, _rngEach.Offset(x, y).Left + 5, _rngEach.Offset(x, y).Top + 5, _20, 20)shp.SelectWith Selection.ShapeRange.LockAspectRatio = msoFalse'撤销锁定图片纵横比.Height = rngEach.Offset(x, y).Height - 10 '图片高度.Width = rngEach.Offset(x, y).Width - 10 '图片宽度End Withb = True '标记找到结果n = n + 1 '累加找到结果的个数Range("a1").Select: Exit For '找到结果后就可以退出文件格式循环End IfNextIf b = False Then k = k + 1 '如果没找到图片累加个数End IfNextApplication.ScreenUpdating = TrueMsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"
End Sub

 

二十八 修改单元格内容会被记录到批注

比如把这个7修改成20，明天改成15，如果没备份就不知道原始数据是什么了。想说明哪一天什么时候把什么改成什么了。

'在所有过程之前用Dim语句定义的变量r1是模块级变量，应模块中所有的过程都可以使用它
Dim r1 '定义一个模块给变量，用户保存单元格的数据
'第一个事件过程，用于记录被更改前单元格中保存的数据
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count <> 1 Then Exit Sub '选中多个单元格时退出程序
If Target.Formula = "" Then '根据选中单元格中保存的数据，确定给变量r1赋什么值r1 = "空"
Elser1 = Target.Text
End If
End Sub
'第二个事件过程，用于批注记录单元格修改前后的信息
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count <> 1 Then Exit Sub
'定义变量保存单元格修改后的内容
Dim r2
'判断单元格是否被修改为空单元格
If Target.Formula = "" Thenr2 = "空"
Elser2 = Target.Formula
End If
'如果单元格修改前后的内容一样则退出程序
If r1 = r2 Then Exit Sub
'定义一个批注变量
Dim r3
'定义一个变量保存批注内容
Dim r4
'将被修改单元格的批注赋给变量r3
Set r3 = Target.Comment
'如果单元格中没有批注则新建批注
If r3 Is Nothing Then Target.AddComment
'将批注的内容保存到变量r4中
r4 = Target.Comment.Text
'重新修改批注的内容=原批注内容+当前日期和时间+原内容+修改后的新内容
Target.Comment.Text Text:=r4 & Chr(10) & Format(Now(), "yyyy-mm-dd hh:mm") & "原内容:" & r1 & "修改为:" & r2
'根据批注内容自动调整批注大小
Target.Comment.Shape.TextFrame.AutoSize = True
End Sub

双击后粘贴代码后，不用运行，关闭即可。另存为工作簿，选择xlsm。

 

二十九 Excel自动保存

 新建一个空白文件，保存为xlsm格式。

Sub otime()'10秒后自动运行WbSave过程Application.OnTime Now() + TimeValue("00:00:10"), "WbSave"
End Sub
Sub WbSave()ThisWorkbook.Save '保存本工作簿Call otime  '再次运行otime过程
End Sub

 

Private Sub Workbook_Open()
Call otime
End Sub

   

然后 CTRL S 保存一下。 

以后再打开这个文件写东西就可以自动保存了。10秒自动保存一次。