Excel VBA常用代码

这张思维导图，将日常工作中常用到的excel批量操作，进行成熟的l宏代码进行总结，只要会打开excel，拷贝备注里的代码到你的excel中，就可以运行，绝对的小白的福音，让你的excel技术进大一步！

Excel VBA常用代码

• 启用宏准备
  • 开发工具
    • 打开Excel=》文件=》选项=》自定义功能区=》开发工具=》确定
  • 启动宏
    • 文件=》选项=》信任中心=》信任中心设置=》宏设置=》启用所有宏（不推荐：可能会运行潜在危险的代码）=》确定
• 同一个工作簿下的操作
  • 批量创建、删除、提取、指定删除工作表
    • 批量创建工作表
      • 用于在一个工作簿下批量添加工作表
        • 1、首先创建一个工作表，在第一行输入任意标题
        • 2、从第二行还是输入你要批量创建的工作表名，一次往下添加 注意：表名只能是字符，如果要添加数字或是日期，需在输入的内容前添加一个英文的单引号后再输入下拉即可
        • 3、打开宏，输入代码运行即可
      • 宏代码
        • Sub NewSht() Dim shtActive As Worksheet, sht As Worksheet Dim i As Long, strShtName As String On Error Resume Next '当代码出错时继续运行 Set shtActive = ActiveSheet For 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 If Next shtActive.Activate '重新激活原工作表 End Sub
    • 删除全部工作表
      • 删除工作表只保留最后一张表
      • 宏代码
        • Sub DelShet() '删除所有工作表 Dim sht As Worksheet Application.ScreenUpdating = False '关屏幕刷新 Application.DisplayAlerts = False '关警告信息 On Error Resume Next For Each sht In Worksheets sht.Delete '遍历工作表删除 Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
    • 提取工作表名字
      • 把同一个工作簿里的所有的工作表的名字都提取到一个工作表中
      • 宏代码
        • Sub GetShtByVba() Dim sht As Worksheet, k As Long Application.ScreenUpdating = False k = 1 Range("a:b").Clear '清空数据 Range("a:a").NumberFormat = "@" '设置文本格式 For Each sht In Worksheets '遍历工作表取表名 k = k + 1 Cells(k, 1) = sht.Name Next Range("a1:b1") = Array("工作表名", "是否删除") Application.ScreenUpdating = True End Sub
    • 删除指定工作表
      • 先用003把同一个工作簿下的所有的工作表的表名先提取出来，然后再要删除表名单元格后一个单元格内写入“删除”，复制代码即可
      • 宏代码
        • Sub DelShtByVba() Dim sht As Worksheet, i As Long, r Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next r = Range("a1").CurrentRegion '数据装入数组r For i = 2 To UBound(r) '遍历并删除工作表 If r(i, 2) = "删除" Then Worksheets(CStr(r(i, 1))).Delete Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
  • 在一同个工作簿中创建工作表的超链接
    • 生成带超链接的工作表目录
      • 在同一个工作簿下生成一个带有超链接的目录，方便对工作簿下所有工作的查看
      • 宏代码
        • Sub ml() Dim sht As Worksheet, i&, strShtName$ Columns(1).ClearContents '清空A列数据 Cells(1, 1) = "目录" '第一个单元格写入标题"目录" i = 1 '将i的初值设置为1. For Each sht In Worksheets '循环当前工作簿的每个工作表 strShtName = sht.Name If strShtName <> ActiveSheet.Name Then '如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接 i = i + 1 '累加工作表数量 ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _ SubAddress:="'" & strShtName & "'!a1", TextToDisplay:=strShtName '建超链接 End If Next End Sub
    • 在各个分表创建返回总表的命令按钮
      • 事项将有所有表超链接的工作表重命名为“总表”
      • 宏代码
        • Dim strShtName As String Sub Mybutton() Dim sht As Worksheet, btn As Button On Error Resume Next For Each sht In Worksheets With sht If .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 With End If End With Next Set btn = Nothing End Sub Sub LinkTable() strShtName = "总表"'指定了返回总表的名字，可以根据实际需要修改为目标表的名称，比如“目录”。 '设置变量strShtName为总表的名称，可以根据实际总表的名称做修改 Worksheets(strShtName).Activate [a1].Select End Sub
  • 在一同个工作簿批量操作工作表名
    • 批量提取工作表的名字（方式一）
      • 将同一个工作簿内的所有工作表名展示在第一张工作表的第一列中
      • 宏代码
        • Sub GetShtName() Dim sht As Worksheet, i As Long i = 1 'i初始值为1 With Columns(1) .ClearContents '清除A列内容 .NumberFormat = "@" '设置单元格格式为文本 End With Cells(1, 1) = "工作表名称目录" For Each sht In Worksheets '遍历工作表 i = i + 1 Cells(i, 1) = sht.Name '在A列记录工作表名称 Next End Sub
    • 批量修改工作表的名字（方式二）
      • 对展示的工作表名进行修改，将要修改的名字对对应的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列的值，赋予变量strShtName Worksheets(strShtName).Name = Cells(i, 2).Value '工作表重命名 Next End Sub
  • 批量取消工作表的隐藏
    • 一键取消同一个工作簿下所有工作表的影藏
    • 宏代码
      • Sub unShtVisible() Dim sht As Worksheet For Each sht In Worksheets '遍历工作表，设置可见 sht.Visible = xlSheetVisible Next End Sub
  • 一键汇总各分表数据成总表【不保留分表格式】
    • 不带格式的将同一个工作簿下所有工作表的内容合并的第一张工作总表中，在运行宏代码是要输入标题的行数，流出标题的位置，注意代码只适用于每张表结构相同的表
    • 宏代码
      • 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).Copy Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues End If End If Next [a1].Activate Application.ScreenUpdating = True '恢复屏幕刷新 End Sub
  • 汇总分表成总表（保留分表格式）
    • 宏代码
      • Sub CollectDataFromShtFormat() Dim sht As Worksheet, rng As Range, k As Long, nTitleCount As Long On Error Resume Next nTitleCount = Val(InputBox("请输入标题的行数", "提醒", 1)) If nTitleCount < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub Application.ScreenUpdating = False Cells.ClearContents '清空当前表数据 For Each sht In Worksheets '遍历工作表 If sht.Name <> ActiveSheet.Name Then '如果工作表名称不等于当前表名则进行汇总动作…… Set rng = sht.UsedRange k = 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).Copy With Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1) .PasteSpecial Paste:=xlPasteFormats '粘贴格式 .PasteSpecial Paste:=xlPasteValues '粘贴数值 End With End If End If Next Range("a1").Activate Application.ScreenUpdating = True '恢复屏幕刷新 MsgBox "汇总OK，一共汇总了：" & k & "张工作表" End Sub
  • 工作表排序
    • 对同一个工作簿下的所有工作表按照我的需求进行先后的排序
    • 宏代码
      • 用于将同以工作簿的表名进行汇总
        • Sub GetShtName() Dim k As Long, sht As Worksheet Application.ScreenUpdating = False With Columns(1) .ClearContents '清空A列原有数据 .NumberFormat = "@" '设置单元格格式为文本 End With Cells(1, 1) = "目录" k = 1 For Each sht In ThisWorkbook.Worksheets '遍历工作表 If sht.Name <> ActiveSheet.Name Then '如果sht不等于当前工作表名称 k = k + 1 '累加工作表个数 Cells(k, 1) = sht.Name '工作表名称写入A列 End If Next Application.ScreenUpdating = True End Sub
      • 汇总后将表名按照你的规则进行排序后再执行宏进行实际的工作表排序
        • Sub SortSht() Dim shtActive As Worksheet, i As Long Dim arr, strShtName As String On Error Resume Next Application.ScreenUpdating = False Set shtActive = ActiveSheet '当前表赋值变量shtactive arr = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row) 'A列数据装入数组arr For i = 2 To UBound(arr) '遍历数组arr strShtName = arr(i, 1) Worksheets(strShtName).Move after:=Worksheets(i - 1) '指定工作表按顺序排放 Next shtActive.Select '回到操作表 Application.ScreenUpdating = True End Sub
  • 批量工作表的加密和解密
    • 工作表保护就是可以打开工作表，但是不能对工作表的内容进行修改和复制
    • 批量工作表加密
      • 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 UnProtct() MsgBox "破解提示：当要求输入密码时请点击取消！”" Application.DisplayAlerts = False On Error Resume Next Dim sht As Worksheet For Each sht In Worksheets With 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 .Unprotect End With Next MsgBox "ok" End Sub
  • 选中行或列会填充颜色
    • 当光标指定某一格时会自动将所在的列和行标注颜色，方便查看，注意，这里的宏代码不保存且用“Thisworkbook”打开
    • 宏代码
      • Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Application.ScreenUpdating = False Cells.Interior.ColorIndex = -4142 '取消单元格原有填充色，但不包含条件格式产生的颜色。 Rows(Target.Row).Interior.ColorIndex = 33 '活动单元格整行填充颜色 Columns(Target.Column).Interior.ColorIndex = 33 '活动单元格整列填充颜色 Application.ScreenUpdating = True End Sub
  • 将Word表格批量写入Excel
    • 宏代码
      • Sub GetWordTable() Dim WdApp As Object Dim objTable As Object Dim objDoc As Object Dim strPath As String Dim shtEach As Worksheet Dim shtSelect As Worksheet Dim i As Long Dim j As Long Dim x As Long Dim y As Long Dim k As Long Dim brr As Variant Set WdApp = CreateObject("Word.Application") With Application.FileDialog(msoFileDialogFilePicker) .Filters.Add "Word文件", "*.doc*", 1 '只显示word文件 .AllowMultiSelect = False '禁止多选文件 If .Show Then strPath = .SelectedItems(1) Else Exit Sub End With Application.ScreenUpdating = False Application.DisplayAlerts = False Set shtSelect = ActiveSheet '当前表赋值变量shtSelect，方便代码运行完成后叶落归根回到开始的地方 For Each shtEach In Worksheets '删除当前工作表以外的所有工作表 If shtEach.Name <> shtSelect.Name Then shtEach.Delete Next shtSelect.Name = "孙兴华" '这句代码不是无聊，作用在于……你猜…… '……其实是避免下面的程序工作表名称重复 Set objDoc = WdApp.documents.Open(strPath) '后台打开用户选定的word文档 For Each objTable In objDoc.tables '遍历文档中的每个表格 k = k + 1 Worksheets.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) '以下遍历行列，数据写入数组brr For i = 1 To x For j = 1 To y brr(i, j) = "'" & Application.Clean(objTable.cell(i, j).Range.Text) 'Clean函数清除制表符等 '半角单引号将数据统一转换为文本格式，避免身份证等数值变形 Next Next With [a1].Resize(x, y) .Value = brr '数据写入Excel工作表 .Borders.LineStyle = 1 '添加边框线 End With Next shtSelect.Select objDoc.Close: WdApp.Quit Application.ScreenUpdating = True Application.DisplayAlerts = True Set objDoc = Nothing Set WdApp = Nothing MsgBox "共获取：" & k & "张表格的数据。" End Sub
  • 取消复杂的合并单元格
    • 取消合并后的单元后将空格自动填充
    • 宏代码
      • Sub UnMergeRange2() '取消合并单元格 Dim MaxRow As Integer ' Dim Rng As Range Dim x%, y%, m%, n%, i% Dim Rng2 As Range On Error Resume Next Set Rng = Application.InputBox("请选择需要取消合并单元格的区域：", _ "区域选择", , , , , , 8) For x = 1 To Rng.Rows.Count For y = 1 To Rng.Columns.Count Set Rng2 = Rng.Cells(x, y) i = Rng2.MergeArea.Count If i > 1 Then m = Rng2.MergeArea.Rows.Count n = Rng2.MergeArea.Columns.Count Rng2.UnMerge '取消合并单元格 Rng2.Resize(m, n).Value = Rng2.Value End If Next Next End Sub
  • 批量添加图片到一张工作表
    • 批量将图片插入到单元格批注中
      • 将图片批量加入到一张工作表中对应的内容的备注中，注意照片名与表格的要插入的名字一致
      • 宏代码
        • Sub AddCommentPic() Dim arr, i&, k&, n&, b As Boolean Dim 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 Sub End With If Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\" Set rngData = Application.InputBox("请选择需要插入图片到批注中的单元格区域", Type:=8) '用户选择需要插入图片到批注中的单元格或区域 If rngData.Count = 0 Then Exit Sub Set rngData = Intersect(rngData.Parent.UsedRange, rngData) 'intersect语句避免用户选择整列单元格，造成无谓运算的情况 If rngData Is Nothing Then MsgBox "选择单元格不能全为空。": Exit Sub arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif") '用数组变量记录五种文件格式 Application.ScreenUpdating = False For 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 With b = True '标记找到结果 n = n + 1 '累加找到结果的个数 Exit For '找到结果后就可以退出文件格式循环 End If Next If b = False Then k = k + 1 '如果没找到图片累加个数 End If Next MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。" Application.ScreenUpdating = True End Sub
    • 批量将图片插入到表格中
      • 宏代码
        • Sub InsertPic() Dim arr, i&, k&, n&, b As Boolean Dim strPicName$, strPicPath$, strFdPath$, shp As Shape Dim 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 Sub End With If 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 Sub strWhere = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1") '用户输入图片相对单元格的偏移位置。 If Len(strWhere) = 0 Then Exit Sub x = Left(strWhere, 1) '偏移的方向 If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Sub y = Val(Mid(strWhere, 2)) '偏移的值 Select Case x Case "上" 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 Select Application.ScreenUpdating = False rngData.Parent.Parent.Activate '用户选定的激活工作簿 rngData.Parent.Select For Each shp In ActiveSheet.Shapes '如果旧图片存放在目标图片存放范围则删除 If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete Next x = rngWhere.Row - rngData.Row y = 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.Select With Selection .ShapeRange.LockAspectRatio = msoFalse '撤销锁定图片纵横比 .Height = rngEach.Offset(x, y).Height - 10 '图片高度 .Width = rngEach.Offset(x, y).Width - 10 '图片宽度 End With b = True '标记找到结果 n = n + 1 '累加找到结果的个数 Range("a1").Select: Exit For '找到结果后就可以退出文件格式循环 End If Next If b = False Then k = k + 1 '如果没找到图片累加个数 End If Next Application.ScreenUpdating = True MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。" End Sub
  • 修改单元格内容会被记录到批注
    • 可以对修改的工作表进行修改备份，打开开发者工具，对要进行备注操作的表双击，直接复制代码，然后关闭，将文件保存为“xlms”启动宏模式后，即可使用
    • 宏代码
      • '在所有过程之前用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 = "空" Else r1 = 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 = "" Then r2 = "空" Else r2 = 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
  • Excel文件按你指定的时间自动保存
    • 宏代码
      • 1、打开开发工具，对要设置定时保存的表右键插入模块复制第一段代码
        • Sub otime() '10秒后自动运行WbSave过程 Application.OnTime Now() + TimeValue("00:00:10"), "WbSave" End Sub Sub WbSave() ThisWorkbook.Save '保存本工作簿 Call otime '再次运行otime过程 End Sub
      • 2、操作玩第一步后，在"Thisworkbook"这里双击复制第二段代码，然后保存为“xlms”格式即可
        • Private Sub Workbook_Open() Call otime End Sub
• 多个工作簿操作
  • 批量将工作表转换为独立的工作簿
    • 宏代码
      • 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
  • 按指定名称批量创建工作簿
    • 在一个工作表中把要批量创建的工作簿的名称写在A列，从A2单元格开始写，执行代码即可
    • 宏代码
      • Sub CreateFiles() Dim strPath As String, strFileName As String Dim i As Long, r 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 & "\" Application.ScreenUpdating = False '取消屏幕刷新 Application.DisplayAlerts = False '取消警告提示，当有重名工作簿时直接覆盖 r = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row) '数据装入数组r For i = 2 To UBound(r) '标题不要，因此从第2个元素开始遍历数组r With Workbooks.Add '新建工作簿 .SaveAs strPath & r(i, 1), xlWorkbookDefault '以指定名称、默认文件类型保存工作簿 .Close True '关闭工作簿 End With Next Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "创建完成。" End Sub
• 配合文件夹的Excel批量操作
  • 按指定条件批量删除工作簿
    • 宏代码
      • 1、执行第一个代码，将指定要删除的文件夹中的工作簿路径集合在工作表中
        • Sub GetFiles() Dim strPath As String, strFileName As String, k As Long With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then strPath = .SelectedItems(1) Else: Exit Sub '获取用户选择的文件夹的路径，如果未选取，则退出程序 End With If Right(strPath, 1) <> "\" Then strPath = strPath & "\" Application.ScreenUpdating = False Range("a:b").Clear: k = 1 '清除A:B列的所有 Cells(1, 1) = "旧文件名": Cells(1, 2) = "是否删除" strFileName = Dir(strPath & "*.xls*") Do While strFileName <> "" k = k + 1 Cells(k, 1) = strPath & strFileName strFileName = Dir Loop Application.DisplayAlerts = True End Sub
      • 2、在路径后面的空格中输入“删除”，执行第二个代码即可
        • Sub DeleteFile() Dim r, i As Long r = Range("a1").CurrentRegion '数据装入数组 For i = 2 To UBound(r) '标题行不要，从数组第二行开始遍历 If r(i, 2) = "删除" Then Kill r(i, 1) 'Kill语句删除指定文件 Next MsgBox "完成。" End Sub
  • 批量获取指定文件夹下文件名并创建超链接
    • 宏代码
      • Sub GetFiles() Dim strPath As String, strFileName As String, k As Long With Application.FileDialog(msoFileDialogFolderPicker) '用户选择文件夹路径 If .Show Then strPath = .SelectedItems(1) Else Exit Sub '如果用户为选择文件夹则退出程序 End With If 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函数，未使用任何参数，则同目录下的下一个文件名 Loop Application.ScreenUpdating = True MsgBox "一共读取了：" & k-1 & "个文件名。" End Sub
  • 批量给工作簿重命名
    • 宏代码
      • 1、对文件夹下的Excel文件进行批量重命名，注意仅限Excel文件 新建一个Excel工作表，执行第一个代码，将指定文件夹下的Excel文件目录路径进行集合
        • Sub GetFiles() Dim strPath As String, strFileName As String, k As Long With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then strPath = .SelectedItems(1) Else: Exit Sub '获取用户选择的文件夹的路径，如果未选取，则退出程序 End With If Right(strPath, 1) <> "\" Then strPath = strPath & "\" Application.ScreenUpdating = False Range("a:b").Clear: k = 1 '清除A:B列的所有 Cells(1, 1) = "旧文件名": Cells(1, 2) = "新文件名" strFileName = Dir(strPath & "*.xls*") Do While strFileName <> "" k = k + 1 Cells(k, 1) = strPath & strFileName strFileName = Dir Loop Application.DisplayAlerts = True End Sub
      • 2、将获取道德路径复制在第二列，将要改的路径后文件名称进行变更，执行第二个代码即可
        • Sub ChangeFileName() Dim r, i As Long r = Range("a1").CurrentRegion '数据装入数组 For i = 2 To UBound(r) '标题行不要，从数组第二行开始遍历 Name r(i, 1) As r(i, 2) 'Name语句重命名 Next MsgBox "更名完成。" End Sub
  • 获取多层文件夹下文件名并创建超链接
    • 可以一个文件夹下的所有文件进行超链接在一个Excel工作表中
    • 宏代码
      • Sub AutoAddLink() Dim strFldPath As String With Application.FileDialog(msoFileDialogFolderPicker) '用户选择指定文件夹 .Title = "请选择指定文件夹。" If .Show Then strFldPath = .SelectedItems(1) Else Exit Sub '未选择文件夹则退出程序，否则将地址赋予变量strFldPath End With Application.ScreenUpdating = False '关闭屏幕刷新 Range("a:b").ClearContents Range("a1:b1") = Array("文件夹", "文件名") Call SearchFileToHyperlinks(strFldPath) '调取自定义函数SearchFileToHyperlinks Range("a:b").EntireColumn.AutoFit '自动列宽 Application.ScreenUpdating = True '重开屏幕刷新 End Sub Function SearchFileToHyperlinks(ByVal strFldPath As String) As String Dim objFld As Object Dim objFile As Object Dim objSubFld As Object Dim strFilePath As String Dim lngLastRow As Long Dim intNum As Integer Set objFld = CreateObject("Scripting.FileSystemObject").GetFolder(strFldPath) '创建FileSystemObject对象引用 For Each objFile In objFld.Files '遍历文件夹内的文件 lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 strFilePath = objFile.Path intNum = 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 objFile For Each objSubFld In objFld.SubFolders '遍历文件夹内的子文件夹 Call SearchFileToHyperlinks(objSubFld.Path) Next objSubFld Set objFld = Nothing Set objFile = Nothing Set objSubFld = Nothing End Function