建议收藏：这10段Excel VBA硬核代码，才是打工人效率飞升的真相！

Excel不是不够强，是你还不知道它能这样用！

还在羡慕那些用Python、R搞数据分析的同事？

打开网易新闻 查看精彩图片

其实你手边的Excel vbA就能完成大多数办公自动化任务。今天分享的10个代码案例，每个都是从真实工作场景中提炼，让你摆脱重复劳动的折磨。

痛点洞察：

为什么ChatGPT生成的VBA代码总差点意思？因为通用代码无法解决你公司特有的表格结构、命名规则、业务流程！

今天这些代码都预留了自定义接口，你只需要修改几个参数，就能直接套用。

一、 工作表智能管理：从混乱到有序的自动化手术

核心思路：将手动操作转化为批量逻辑，让Excel自己管理自己。

案例1：按名单批量创建工作表（升级版：带目录索引）

痛点：每次为新项目、新员工、新客户创建独立工作表，手动操作不仅耗时，还容易遗漏或命名不规范。

解决方案升级：一键生成工作表，并自动创建带超链接的目录页，方便快速导航。

Sub 批量创建带目录的工作表()Dim wsList As Worksheet, wsNew As Worksheet, wsToc As WorksheetDim rng As Range, cell As RangeDim i As Integer, lastTocRow As LongSet wsList = ThisWorkbook.Sheets("名单源")Set rng = wsList.Range("A2:A" & wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row)'---【新增干货】创建或更新目录工作表---On Error Resume NextSet wsToc = ThisWorkbook.Sheets("目录")If wsToc Is Nothing ThenSet wsToc = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))wsToc.Name = "目录"wsToc.Range("A1:B1").Value = Array("序号", "工作表名称")wsToc.Range("A1:B1").Font.Bold = TrueElsewsToc.Cells.ClearwsToc.Range("A1:B1").Value = Array("序号", "工作表名称")End IflastTocRow = 1Application.ScreenUpdating = FalseFor Each cell In rngIf cell.Value <> "" ThenOn Error Resume NextSet wsNew = ThisWorkbook.Sheets(cell.Value)On Error GoTo 0If wsNew Is Nothing ThenSet wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsNew.Name = cell.Value'核心表头初始化（根据你的业务修改）wsNew.Range("A1:F1").Value = Array("姓名", "部门", "岗位", "基本工资", "绩效", "备注")wsNew.Range("A1:F1").Font.Bold = TruewsNew.Range("A1:F1").Interior.Color = RGB(198, 224, 255) '更专业的颜色wsNew.Range("A2").Value = cell.Value'---【新增干货】在目录中添加记录和超链接---lastTocRow = lastTocRow + 1wsToc.Cells(lastTocRow, 1).Value = lastTocRow - 1wsToc.Cells(lastTocRow, 2).Value = cell.ValuewsToc.Hyperlinks.Add Anchor:=wsToc.Cells(lastTocRow, 2), _Address:="", _SubAddress:="'" & cell.Value & "'!A1", _TextToDisplay:=cell.ValueEnd IfSet wsNew = NothingEnd IfNext cellwsToc.Columns("A:B").AutoFitApplication.ScreenUpdating = TrueMsgBox "操作完成！已创建/更新目录，并处理了 " & rng.Count & " 个项目。", vbInformationEnd Sub

效率对比：

• 手动操作：创建100个工作表 + 命名 + 设置表头 ≈ 2小时，且易出错。
• VBA自动化：10秒完成，包含目录生成和格式化。

案例2：批量删除隐藏工作表（增强安全版）

痛点：项目结束后遗留大量隐藏的草稿、计算过程表，手动查找删除既麻烦又危险，容易误删。

解决方案升级：增加对“非常隐藏”工作表的检查，并提供删除前数据预览。

Sub 增强版批量删除隐藏表()Dim ws As WorksheetDim delCount As Integer, veryHiddenCount As IntegerDim response As VbMsgBoxResultDim logMsg As String'安全警告response = MsgBox("即将永久删除所有隐藏及非常隐藏的工作表！" & vbCrLf & _"建议先对工作簿另存为备份。" & vbCrLf & vbCrLf & _"是否继续？", vbCritical + vbYesNo, "⚠️ 高危操作警告")If response = vbNo Then Exit SublogMsg = "即将删除以下工作表：" & vbCrLf & vbCrLfdelCount = 0veryHiddenCount = 0'第一次遍历：收集信息，不直接删除For i = ThisWorkbook.Sheets.Count To 1 Step -1Set ws = ThisWorkbook.Sheets(i)If ws.Visible = xlSheetHidden ThenlogMsg = logMsg & " [隐藏] " & ws.Name & vbCrLfdelCount = delCount + 1ElseIf ws.Visible = xlSheetVeryHidden ThenlogMsg = logMsg & " [非常隐藏] " & ws.Name & vbTab & "→ 需要先取消非常隐藏状态" & vbCrLfveryHiddenCount = veryHiddenCount + 1delCount = delCount + 1End IfNext iIf delCount = 0 ThenMsgBox "未发现隐藏或非常隐藏的工作表。", vbInformationExit SubEnd If'显示待删除列表，再次确认logMsg = logMsg & vbCrLf & "总计：" & delCount & " 个工作表。" & vbCrLfIf veryHiddenCount > 0 Then logMsg = logMsg & "(其中 " & veryHiddenCount & " 个为非常隐藏)"response = MsgBox(logMsg & vbCrLf & vbCrLf & "确认执行删除？", vbExclamation + vbYesNo, "最终确认")If response = vbNo Then Exit Sub'第二次遍历：执行删除Application.ScreenUpdating = FalseApplication.DisplayAlerts = False '禁用删除确认弹窗delCount = 0For i = ThisWorkbook.Sheets.Count To 1 Step -1Set ws = ThisWorkbook.Sheets(i)If ws.Visible <> xlSheetVisible Thenws.DeletedelCount = delCount + 1End IfNext iApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "清理完成！已安全删除 " & delCount & " 个隐藏工作表。", vbInformationEnd Sub

案例3：工作表智能排序（支持自定义规则）

痛点：工作表顺序杂乱无章，不符合业务流程（如按月份、部门、项目阶段排序）。

解决方案升级：支持多种预设规则，并允许用户输入自定义的排序列表。

Sub 高级工作表排序()'方法：通过将工作表移动到末尾的顺序，来间接实现排序Dim targetOrder As StringDim orderArray() As StringDim i As Integer, j As Integer'---【新增干货】提供几种常用规则选项---Dim ruleChoice As IntegerruleChoice = Application.InputBox( _"请选择排序规则：" & vbCrLf & _"1 - 按月份（一月到十二月）" & vbCrLf & _"2 - 按季度（Q1到Q4）" & vbCrLf & _"3 - 按部门（销售、技术、人事...）" & vbCrLf & _"4 - 自定义（请输入以逗号分隔的表名）", _"选择排序规则", 1, Type:=1)Select Case ruleChoiceCase 1targetOrder = "一月,二月,三月,四月,五月,六月,七月,八月,九月,十月,十一月,十二月"Case 2targetOrder = "Q1,Q2,Q3,Q4"Case 3targetOrder = "销售部,技术部,市场部,财务部,行政部,人力资源部"Case 4targetOrder = Application.InputBox("请输入工作表名称，用逗号分隔：", "自定义排序")If targetOrder = "" Then Exit SubCase ElseExit SubEnd SelectorderArray = Split(targetOrder, ",")Application.ScreenUpdating = False'核心排序逻辑：按指定顺序，将表依次移到最后For i = 0 To UBound(orderArray)On Error Resume Next '如果某个名称的表不存在，则跳过ThisWorkbook.Sheets(Trim(orderArray(i))).Move _After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)On Error GoTo 0Next iApplication.ScreenUpdating = TrueMsgBox "工作表排序完成！当前顺序已按照规则调整。", vbInformationEnd Sub

二、 数据汇总与拆分：让报表自动化飞起来

核心思路：用代码模拟“复制粘贴”，但实现精准、无误、批量的操作。

案例4：多部门/分店数据一键汇总（企业级方案）

痛点：每月底，财务或运营需要收集几十个部门的Excel报表，手动打开、复制、粘贴，耗时耗力且容易遗漏或错位。

解决方案升级：自动识别不同部门表的结构差异，并生成带有时间戳和汇总分析的“总驾驶舱”。

Sub 企业级多表数据汇总()Dim wsSummary As Worksheet, ws As WorksheetDim lastRow As Long, summaryRow As Long, headerRow As LongDim wsCount As Integer, totalRecords As LongDim startTime As DoublestartTime = Timer '记录开始时间'---【新增干货】创建专业的汇总工作表---On Error Resume NextApplication.DisplayAlerts = FalseThisWorkbook.Sheets("数据驾驶舱").DeleteApplication.DisplayAlerts = TrueOn Error GoTo 0Set wsSummary = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))wsSummary.Name = "数据驾驶舱"'设置固定表头（假设需要这些字段，请根据实际修改）wsSummary.Range("A1:G1").Value = Array("数据源", "日期", "部门", "产品线", "销售额", "销售量", "毛利率")With wsSummary.Range("A1:G1").Font.Bold = True.Interior.Color = RGB(22, 54, 92) '深蓝色.Font.Color = RGB(255, 255, 255).HorizontalAlignment = xlCenterEnd WithApplication.ScreenUpdating = FalsesummaryRow = 2wsCount = 0totalRecords = 0For Each ws In ThisWorkbook.Worksheets'跳过非数据工作表If ws.Name <> wsSummary.Name And ws.Name <> "名单源" And ws.Name <> "目录" Then'---【关键干货】智能查找表头行和末行---'假设表头在第一行，且有关键字“销售额”headerRow = 1lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row'查找“销售额”列（假设需要此列）Dim salesCol As LongsalesCol = 0For i = 1 To 20 '检查前20列If InStr(ws.Cells(headerRow, i).Value, "销售额") > 0 ThensalesCol = iExit ForEnd IfNext iIf salesCol > 0 And lastRow > headerRow Then'从表头下一行开始复制数据ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).Copy _wsSummary.Cells(summaryRow, 1)'在“数据源”列填入工作表名wsSummary.Range("A" & summaryRow & ":A" & summaryRow + lastRow - headerRow - 1).Value = ws.NametotalRecords = totalRecords + (lastRow - headerRow)summaryRow = summaryRow + (lastRow - headerRow)wsCount = wsCount + 1End IfEnd IfNext ws'---【新增干货】生成汇总统计和图表区域---Dim statsRow As LongstatsRow = summaryRow + 3wsSummary.Cells(statsRow, 1).Value = "汇总统计"wsSummary.Cells(statsRow, 1).Font.Bold = TruewsSummary.Cells(statsRow + 1, 1).Value = "数据源工作表数："wsSummary.Cells(statsRow + 1, 2).Value = wsCountwsSummary.Cells(statsRow + 2, 1).Value = "汇总记录总条数："wsSummary.Cells(statsRow + 2, 2).Value = totalRecordswsSummary.Cells(statsRow + 3, 1).Value = "总计销售额："wsSummary.Cells(statsRow + 3, 2).Formula = "=SUM(E2:E" & summaryRow - 1 & ")"wsSummary.Cells(statsRow + 3, 2).NumberFormat = "#,##0.00"wsSummary.Cells(statsRow + 4, 1).Value = "处理耗时："wsSummary.Cells(statsRow + 4, 2).Value = Format((Timer - startTime), "0.00") & " 秒"'美化表格With wsSummary.Columns("A:G").AutoFit.Range("E2:E" & summaryRow - 1).NumberFormat = "#,##0.00".Range("A1:G" & summaryRow - 1).Borders.LineStyle = xlContinuous.Range("A1:G" & summaryRow - 1).HorizontalAlignment = xlCenterEnd WithApplication.ScreenUpdating = TrueMsgBox "数据驾驶舱生成完毕！" & vbCrLf & _"合并了 " & wsCount & " 个工作表，共 " & totalRecords & " 条记录。" & vbCrLf & _"耗时：" & Format((Timer - startTime), "0.00") & " 秒", vbInformationEnd Sub

真实案例：某零售集团运营部，每月合并全国200+门店销售数据，从原先3人3天的工作量，压缩为单人10分钟完成。

案例5：按条件（如地区、产品）拆分数据（邮件分发就绪版）

痛点：总部有一张全国销售总表，需要按省份拆分后分别发给各区域经理，手动筛选复制效率极低。

解决方案升级：拆分后自动保存在以“地区”命名的新工作簿中，并添加分发说明，可直接作为邮件附件。

Sub 按地区拆分数据_分发生成版()Dim wsSource As Worksheet, wsDest As Worksheet, wbNew As WorkbookDim lastRow As Long, i As LongDim keyCol As Long, keyValue As StringDim dict As ObjectDim key As VariantDim savePath As StringDim startTime As DoublestartTime = TimerSet wsSource = ThisWorkbook.Sheets("全国销售总表")Set dict = CreateObject("Scripting.Dictionary")'---【核心逻辑】自动识别拆分依据列（例如“省份”）---keyCol = 0For i = 1 To wsSource.UsedRange.Columns.CountIf InStr(wsSource.Cells(1, i).Value, "省份") > 0 Or _InStr(wsSource.Cells(1, i).Value, "地区") > 0 Then '可添加更多关键字keyCol = iExit ForEnd IfNext iIf keyCol = 0 ThenMsgBox "未找到用于拆分的列（如‘省份’）。请检查表头！", vbExclamationExit SubEnd If'收集所有不重复的键值lastRow = wsSource.Cells(wsSource.Rows.Count, keyCol).End(xlUp).RowFor i = 2 To lastRowkeyValue = Trim(wsSource.Cells(i, keyCol).Value)If keyValue <> "" And Not dict.Exists(keyValue) Thendict.Add keyValue, ""End IfNext i'选择保存路径With Application.FileDialog(msoFileDialogFolderPicker).Title = "请选择拆分文件的保存位置"If .Show ThensavePath = .SelectedItems(1) & ""ElseExit SubEnd IfEnd WithApplication.ScreenUpdating = FalseFor Each key In dict.Keys'对源数据应用筛选wsSource.AutoFilterMode = FalsewsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.UsedRange.Columns.Count)).AutoFilter _Field:=keyCol, Criteria1:=CStr(key)'创建新的独立工作簿Set wbNew = Workbooks.AddSet wsDest = wbNew.Sheets(1)wsDest.Name = "数据"'复制筛选后的可见数据（包括表头）wsSource.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A1")wsDest.Columns.AutoFit'---【新增干货】在新工作簿中添加一个“分发说明”页---Dim wsNote As WorksheetSet wsNote = wbNew.Sheets.Add(Before:=wsDest)wsNote.Name = "说明"wsNote.Range("A1").Value = "数据分发说明"wsNote.Range("A1").Font.Bold = TruewsNote.Range("A3").Value = "负责人：" & key & "区域经理"wsNote.Range("A4").Value = "数据期间：" & Format(Date, "yyyy年mm月")wsNote.Range("A5").Value = "生成时间：" & Now()wsNote.Range("A6").Value = "请查阅《数据》工作表了解详细情况。"wsNote.Columns("A:A").AutoFit'保存并关闭On Error Resume NextwbNew.SaveAs savePath & Format(Date, "yyyymmdd") & "_" & key & "_销售数据.xlsx", FileFormat:=xlOpenXMLWorkbookwbNew.Close SaveChanges:=FalseOn Error GoTo 0wsSource.AutoFilterMode = FalseNext keyApplication.ScreenUpdating = TrueMsgBox "数据拆分完成！" & vbCrLf & _"共生成 " & dict.Count & " 个独立文件。" & vbCrLf & _"保存至：" & savePath & vbCrLf & _"总耗时：" & Format((Timer - startTime), "0.00") & " 秒", vbInformationEnd Sub

三、 工作簿批量操作：文件管理“外挂”

核心思路：让Excel能管理自身和其他文件，实现跨文件自动化。

案例6：合并多个Excel文件数据（跨文件夹版）

痛点：收集上百个同事发来的报表文件，每个都要打开、复制、关闭，繁琐至极。

解决方案升级：支持遍历子文件夹，自动识别不同文件格式，并记录合并日志。

Sub 跨文件夹合并Excel文件()'此代码将合并指定文件夹（含子文件夹）下所有Excel文件的首个工作表数据Dim fso As Object, folder As Object, subFolder As Object, file As ObjectDim wbSource As Workbook, wbDest As WorkbookDim wsSource As Worksheet, wsDest As WorksheetDim destRow As Long, fileCount As Integer, errCount As IntegerDim folderPath As StringDim startTime As DoublestartTime = TimerSet wbDest = ThisWorkbookOn Error Resume NextSet wsDest = wbDest.Sheets("合并总表")If wsDest Is Nothing ThenSet wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count))wsDest.Name = "合并总表"wsDest.Range("A1:F1").Value = Array("来源文件", "路径", "合并时间", "产品", "数量", "金额") '根据实际修改Else'如果表已存在，清空旧数据（保留标题）wsDest.Range("A2:F" & wsDest.Rows.Count).ClearContentsEnd IfOn Error GoTo 0destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1If destRow < 2 Then destRow = 2'选择根文件夹With Application.FileDialog(msoFileDialogFolderPicker).Title = "请选择包含待合并Excel文件的根文件夹"If .Show ThenfolderPath = .SelectedItems(1)ElseExit SubEnd IfEnd WithSet fso = CreateObject("Scripting.FileSystemObject")Set folder = fso.GetFolder(folderPath)fileCount = 0errCount = 0Application.ScreenUpdating = False'调用递归函数遍历所有文件夹Call TraverseFolder(folder)'---【新增干货】生成合并报告---Dim wsLog As WorksheetSet wsLog = wbDest.Sheets.Add(After:=wsDest)wsLog.Name = "合并日志"wsLog.Range("A1").Value = "文件合并报告"wsLog.Range("A2").Value = "合并根目录："wsLog.Range("B2").Value = folderPathwsLog.Range("A3").Value = "合并文件总数："wsLog.Range("B3").Value = fileCountwsLog.Range("A4").Value = "失败文件数："wsLog.Range("B4").Value = errCountwsLog.Range("A5").Value = "合并总耗时："wsLog.Range("B5").Value = Format((Timer - startTime), "0.00") & " 秒"wsLog.Range("A6").Value = "报告生成时间："wsLog.Range("B6").Value = Now()wsLog.Columns("A:B").AutoFitwsDest.Columns.AutoFitApplication.ScreenUpdating = TrueMsgBox "合并完成！" & vbCrLf & _"成功合并 " & fileCount & " 个文件。" & vbCrLf & _"耗时 " & Format((Timer - startTime), "0.00") & " 秒。" & vbCrLf & _"详见《合并总表》和《合并日志》工作表。", vbInformationExit SubTraverseFolder:'递归遍历文件夹的核心子程序Dim f As Object'1. 处理当前文件夹的文件For Each file In folder.FilesIf LCase(Right(file.Name, 4)) = ".xls" Or _LCase(Right(file.Name, 5)) = ".xlsx" Or _LCase(Right(file.Name, 5)) = ".xlsm" Then'排除自身If Not (wbDest.Name = file.Name) ThenOn Error GoTo OpenErrorSet wbSource = Workbooks.Open(file.Path, ReadOnly:=True)Set wsSource = wbSource.Sheets(1) '假设合并第一个工作表Dim srcLastRow As LongsrcLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).RowIf srcLastRow > 1 Then'记录文件来源信息wsDest.Cells(destRow, 1).Value = file.NamewsDest.Cells(destRow, 2).Value = Left(file.Path, Len(file.Path) - Len(file.Name))wsDest.Cells(destRow, 3).Value = Now()'复制数据（假设数据从第2行开始，占据A到D列）wsSource.Range("A2:D" & srcLastRow).Copy wsDest.Cells(destRow, 4)destRow = destRow + (srcLastRow - 1)fileCount = fileCount + 1End IfwbSource.Close SaveChanges:=FalseEnd IfEnd IfNextFile:Next fileOn Error GoTo 0'2. 递归处理子文件夹For Each subFolder In folder.SubFoldersCall TraverseFolder(subFolder)Next subFolderReturnOpenError:errCount = errCount + 1Resume NextFileEnd Sub

四、 安全与权限管理：数据保护的自动化防线

核心思路：将安全策略标准化、批量化执行，防止人为疏忽。

案例8：批量工作表加密（按内容智能加密版）

痛点：含有敏感信息（如薪资、成本）的工作表需要保护，但逐一设置密码繁琐且易遗漏。

解决方案升级：不仅按表名（如包含“薪资”），还能按单元格内容（如特定标题）自动触发加密。

Sub 智能批量工作表加密()Dim ws As WorksheetDim pwd As StringDim encryptCount As IntegerDim searchKeyword As String'---【新增干货】可选择加密策略---Dim strategy As Integerstrategy = Application.InputBox( _"请选择加密策略：" & vbCrLf & _"1 - 按工作表名称（包含‘工资’、‘成本’等）" & vbCrLf & _"2 - 按工作表内容（如查找标题含‘身份证号’的工作表）", _"加密策略", 1, Type:=1)If strategy < 1 Or strategy > 2 Then Exit Subpwd = InputBox("请输入用于保护工作表的密码（建议8位以上）：", "设置密码")If pwd = "" Then Exit SubIf strategy = 2 ThensearchKeyword = InputBox("请输入要搜索的关键字（如‘身份证号’、‘银行卡’）：", "关键字搜索")If searchKeyword = "" Then Exit SubEnd IfApplication.ScreenUpdating = FalseencryptCount = 0For Each ws In ThisWorkbook.WorksheetsDim needProtect As BooleanneedProtect = False'策略1：按表名判断If strategy = 1 ThenIf InStr(ws.Name, "工资") > 0 Or _InStr(ws.Name, "薪资") > 0 Or _InStr(ws.Name, "财务") > 0 Or _InStr(ws.Name, "成本") > 0 Or _InStr(ws.Name, "预算") > 0 Or _InStr(ws.Name, "密") > 0 ThenneedProtect = TrueEnd If'策略2：按内容判断ElseIf strategy = 2 Then'在整个工作表的已使用区域搜索关键字Dim foundCell As RangeSet foundCell = ws.UsedRange.Find(What:=searchKeyword, LookAt:=xlPart, MatchCase:=False)If Not foundCell Is Nothing ThenneedProtect = TrueEnd IfEnd IfIf needProtect ThenIf ws.ProtectContents ThenOn Error Resume Nextws.Unprotect "" '尝试用空密码或旧密码取消保护On Error GoTo 0End If'应用保护，但允许用户执行部分操作，提升实用性ws.Protect Password:=pwd, _AllowFormattingCells:=True, _AllowFormattingColumns:=True, _AllowFormattingRows:=True, _AllowInsertingColumns:=False, _AllowInsertingRows:=False, _AllowDeletingColumns:=False, _AllowDeletingRows:=False, _AllowSorting:=True, _AllowFiltering:=True, _AllowUsingPivotTables:=TrueencryptCount = encryptCount + 1Debug.Print "已加密工作表: " & ws.Name '在立即窗口显示日志End IfNext wsApplication.ScreenUpdating = TrueMsgBox "智能加密完成！" & vbCrLf & _"本次共加密了 " & encryptCount & " 个工作表。" & vbCrLf & _"密码已设置为: " & pwd, vbInformationEnd Sub

五、 数据查询与智能分析：让Excel“思考”

核心思路：将复杂的、需要人脑判断的多条件查询，转化为代码的逻辑判断。

案例10：多条件高级查询（从界面输入条件版）

痛点：在数万行数据中，需要筛选出同时满足“华东区”、“销售额>10万”、“产品为A或B”的记录。高级筛选和公式都较为复杂。

解决方案升级：用户可在Excel指定区域（如一个条件输入区域）设置查询条件，代码动态读取并执行查询，结果清晰呈现。

Sub 动态多条件高级查询()'此代码从一个“查询条件”区域读取条件，并在“数据源”表中查找匹配记录，输出到“查询结果”表Dim wsData As Worksheet, wsCriteria As Worksheet, wsResult As WorksheetDim dataLastRow As Long, dataLastCol As LongDim critLastRow As LongDim resultRow As Long, matchCount As LongDim i As Long, j As Long, k As LongDim criteriaDict As ObjectDim startTime As DoublestartTime = TimerSet wsData = ThisWorkbook.Sheets("数据源")On Error Resume NextSet wsCriteria = ThisWorkbook.Sheets("查询条件")If wsCriteria Is Nothing Then'创建查询条件输入表Set wsCriteria = ThisWorkbook.Sheets.Add(Before:=wsData)wsCriteria.Name = "查询条件"wsCriteria.Range("A1:B1").Value = Array("字段名", "条件")wsCriteria.Range("A1:B1").Font.Bold = True'示例条件wsCriteria.Range("A2").Value = "地区"wsCriteria.Range("B2").Value = "华东"wsCriteria.Range("A3").Value = "产品类别"wsCriteria.Range("B3").Value = "电子产品"wsCriteria.Range("A4").Value = "销售额"wsCriteria.Range("B4").Value = ">10000"wsCriteria.Columns("A:B").AutoFitMsgBox "已创建'查询条件'工作表，请在其中填写您的查询条件（字段名需与数据源表头一致）。", vbInformationEnd IfOn Error GoTo 0'---【核心干货】将查询条件区域读取到字典中---Set criteriaDict = CreateObject("Scripting.Dictionary")critLastRow = wsCriteria.Cells(wsCriteria.Rows.Count, "A").End(xlUp).RowFor i = 2 To critLastRowDim field As String, condition As Stringfield = Trim(wsCriteria.Cells(i, 1).Value)condition = Trim(wsCriteria.Cells(i, 2).Value)If field <> "" And condition <> "" ThencriteriaDict(field) = conditionEnd IfNext iIf criteriaDict.Count = 0 ThenMsgBox "请在'查询条件'工作表中设置至少一个查询条件！", vbExclamationExit SubEnd If'准备结果表On Error Resume NextApplication.DisplayAlerts = FalseThisWorkbook.Sheets("查询结果").DeleteApplication.DisplayAlerts = TrueOn Error GoTo 0Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsResult.Name = "查询结果"'获取数据源范围dataLastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).RowdataLastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column'复制表头wsData.Range(wsData.Cells(1, 1), wsData.Cells(1, dataLastCol)).Copy _wsResult.Range("A1")wsResult.Rows(1).Font.Bold = TrueresultRow = 2Application.ScreenUpdating = False'遍历数据源每一行For i = 2 To dataLastRowDim isMatch As BooleanisMatch = True'遍历每一个查询条件For j = 1 To dataLastColDim dataFieldName As StringdataFieldName = wsData.Cells(1, j).ValueIf criteriaDict.Exists(dataFieldName) ThenDim dataCellValue As Variant, cond As StringdataCellValue = wsData.Cells(i, j).Valuecond = criteriaDict(dataFieldName)'进行条件匹配判断（支持>，<，>=，<=，*通配符，多值）If Not EvaluateCondition(dataCellValue, cond) ThenisMatch = FalseExit For '有一个条件不满足，整行即不满足End IfEnd IfNext j'如果所有条件都满足，则复制该行到结果表If isMatch ThenwsData.Range(wsData.Cells(i, 1), wsData.Cells(i, dataLastCol)).Copy _wsResult.Cells(resultRow, 1)resultRow = resultRow + 1matchCount = matchCount + 1End IfNext i'结果表美化If resultRow > 2 ThenWith wsResult.Columns("A:Z").AutoFit.Range(.Cells(1, 1), .Cells(resultRow - 1, dataLastCol)).Borders.LineStyle = xlContinuous'添加统计信息.Cells(resultRow + 2, 1).Value = "查询摘要".Cells(resultRow + 2, 1).Font.Bold = True.Cells(resultRow + 3, 1).Value = "查询条件数：".Cells(resultRow + 3, 2).Value = criteriaDict.Count.Cells(resultRow + 4, 1).Value = "匹配记录数：".Cells(resultRow + 4, 2).Value = matchCount.Cells(resultRow + 5, 1).Value = "查询耗时：".Cells(resultRow + 5, 2).Value = Format((Timer - startTime), "0.000") & " 秒"End WithEnd IfApplication.ScreenUpdating = True'输出提示Dim condMsg As StringcondMsg = ""For Each key In criteriaDict.KeyscondMsg = condMsg & key & ": " & criteriaDict(key) & vbCrLfNextMsgBox "动态查询完成！" & vbCrLf & vbCrLf & _"查询条件：" & vbCrLf & condMsg & vbCrLf & _"找到 " & matchCount & " 条匹配记录。" & vbCrLf & _"耗时：" & Format((Timer - startTime), "0.000") & " 秒", vbInformationEnd Sub'---【关键干货】独立的条件判断函数---Function EvaluateCondition(cellValue As Variant, condition As String) As Boolean'功能：根据条件字符串，判断单元格值是否满足条件'返回值：True 满足，False 不满足EvaluateCondition = False '默认不满足'处理空值If IsEmpty(cellValue) Or IsNull(cellValue) ThenIf condition = "为空" Or condition = "=空" Then EvaluateCondition = TrueExit FunctionEnd IfDim condLower As StringcondLower = LCase(condition)'1. 判断是否包含比较运算符（>, <, >=, <=）If Left(condLower, 2) = ">=" ThenIf IsNumeric(cellValue) Then EvaluateCondition = cellValue >= Val(Mid(condition, 3))ElseIf Left(condLower, 2) = "<=" ThenIf IsNumeric(cellValue) Then EvaluateCondition = cellValue <= Val(Mid(condition, 3))ElseIf Left(condLower, 1) = ">" ThenIf IsNumeric(cellValue) Then EvaluateCondition = cellValue > Val(Mid(condition, 2))ElseIf Left(condLower, 1) = "<" ThenIf IsNumeric(cellValue) Then EvaluateCondition = cellValue < Val(Mid(condition, 2))'2. 判断是否包含通配符（* 或 ?）ElseIf InStr(condition, "*") > 0 Or InStr(condition, "?") > 0 ThenEvaluateCondition = CStr(cellValue) Like condition'3. 判断是否为多选条件（用逗号分隔）ElseIf InStr(condition, ",") > 0 ThenDim condArray() As StringcondArray = Split(condition, ",")For i = 0 To UBound(condArray)If Trim(CStr(cellValue)) = Trim(condArray(i)) ThenEvaluateCondition = TrueExit ForEnd IfNext i'4. 默认精确匹配ElseEvaluateCondition = CStr(cellValue) = conditionEnd IfEnd Function

VBA实战能力小测验

第一题：在处理大量数据（例如案例4的汇总）时，为了显著提高VBA代码的运行速度，最应该设置以下哪个属性？

A) Application.Calculation = xlCalculationManual

B) Application.ScreenUpdating = False

C) Application.EnableEvents = False

D) 以上全部

第二题：在案例2（批量删除隐藏工作表）中，代码为什么要从 ThisWorkbook.Sheets.Count 到 1 Step -1（从后向前）遍历工作表？

A) 为了按字母逆序排序

B) 因为删除工作表后，剩余工作表的索引会立即改变，从后向前遍历可以避免“下标越界”错误

C) 这样运行速度更快

D) 没有特别原因，只是一种编程习惯

第三题：在案例10（多条件高级查询）的升级版中，我们使用了一个 Dictionary 对象来存储查询条件。这样做的主要优势是什么？

A) 让代码看起来更专业

B) 可以快速根据“字段名”查找到对应的“条件值”，提高匹配效率

C) Dictionary 对象必须使用，VBA没有其他方法

D) 可以自动对条件进行排序

答案：

1. D) 以上全部。关闭屏幕更新、禁用自动计算和事件，是VBA批量操作时的“性能三连”，能极大提升速度。
2. B) 因为删除工作表后，剩余工作表的索引会立即改变，从后向前遍历可以避免“下标越界”错误。这是VBA操作集合对象（如工作表、行）时的一个经典技巧。
3. B) 可以快速根据“字段名”查找到对应的“条件值”，提高匹配效率。Dictionary 提供了键值对的映射关系，查找速度极快，非常适合这种需要频繁根据键（字段名）检索值（条件）的场景。

（完）