Excel VBA编程-一键按条件自动筛选数据并复制成新表

上一讲我们学会了用 VBA「循环群发邮件」，把名单里的人挨个通知到位。但办公里还有一类更常见的活儿：一张几千行的大表里，你只想要「部门=销售」那几十行，或者「地区=华南且状态=未完成」的那几行，手动筛选、复制、粘到新表，又慢又容易漏选。

这一讲我们从网络上整理了一批 Excel VBA「按条件自动筛选并复制」的实用技巧，核心就一句话：用一个 AutoFilter 把想要的行留下来（其余的行只是被藏起来），再用 SpecialCells 只把看得见的行复制出来，粘到一张新建的工作表里。这套做法在国内外都最常用，我们来拆解一下大家公认的要点：

• Excelsamurai 的筛选思路：用 Range("A1").AutoFilter Field:=1, Criteria1:="条件" 在某一列设筛选，配合 SpecialCells(xlCellTypeVisible) 只选中筛出来的行，再 Copy 到别的工作表；还特别提醒「筛选完记得用 ActiveSheet.AutoFilterMode = False 把筛选关掉，恢复全部显示」。
• excelmaster.ai 的关键提醒：AutoFilter 只是「把不符合条件的行藏起来」，并没有删除它们；普通的 .Copy 会把藏起来的行也一起复制走，所以必须走 .SpecialCells(xlCellTypeVisible) 只复制看得见的；另外「.AutoFilter 不带参数会变成开关切换」，所以动手前先 AutoFilterMode = False 清掉旧筛选最稳妥。
• code-examples.net 的实战写法：用 CurrentRegion.SpecialCells(xlCellTypeVisible) 把整块（含表头）一起复制，On Error Resume Next 兜住「筛完没数据」的报错，用 Sheets.Add 建新表接住结果，最后 Application.CutCopyMode = False 去掉虚线边框。
• worldprogramming 的数值筛选：Criteria1:=">30" 还能按大小筛，筛完同样用 SpecialCells(xlCellTypeVisible).Copy 搬到另一张表。
• ExcelMacroClass 的组合筛选经验：在同一个区域上连着两次 .AutoFilter、分别指定不同列，就相当于「列A等于某值 且 列B等于某值」的组合条件。

把这些经验揉到一起，我们这篇只讲一个核心套路：某列设条件 → 只复制看得见的行 → 粘到新表 → 清掉筛选恢复原表。下面用 3 个由浅入深的案例带你走一遍。

（小前提：下面所有代码都假设你当前打开的表里，第 1 行是表头、从 A 列起是数据。运行前先把要处理的那张表点成「当前表」。）

案例一（简单）：一键按固定条件筛选，并复制到一张新表

功能说明 这是最基础的「筛选+搬走」。你只要把数据摆在当前表（比如 A 列姓名、B 列部门、C 列地区……），运行这一段，Excel 就会按「部门列（第 2 列）等于"销售"」把匹配的行挑出来，连同表头一起复制到一张新建的「销售名单」表里，最后把原表的筛选关掉、让所有行重新显示。第一次试，建议先把数据做一份副本再运行。

代码

Sub 一键筛选_固定条件()    ' 当前表：第1行表头，A列起为数据；部门在第2列    ' 按部门="销售" 筛选出匹配行，连同表头复制到新建的「销售名单」表    Dim 源表 As Worksheet    Dim 新表 As Worksheet    Dim 新表数据行 As Long    Set 源表 = ActiveSheet    ' 先清掉可能存在的旧筛选，避免重复点选出错    If 源表.AutoFilterMode Then 源表.AutoFilterMode = False    ' 在第2列（部门）筛选“销售”    源表.Range("A1").AutoFilter Field:=2, Criteria1:="销售"    ' 新建一张表来接结果    Set 新表 = Sheets.Add(After:=Sheets(Sheets.Count))    新表.Name = "销售名单"    ' 只复制看得见的行（含表头），直接粘到新表 A1    源表.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _        Destination:=新表.Range("A1")    ' 还原原表：关掉筛选，所有行重新显示，数据没动过    源表.AutoFilterMode = False    新表.Columns.AutoFit    ' 看看新表里到底复制到了几行数据（减掉表头那1行）    新表数据行 = 新表.Cells(新表.Rows.Count, 1).End(xlUp).Row - 1    If 新表数据行 <= 0 Then        MsgBox "没有找到「部门=销售」的行。", vbExclamation    Else        MsgBox "已筛选出 " & 新表数据行 & " 行「销售」数据，复制到新表「销售名单」。", vbInformation    End IfEnd Sub

操作步骤

1. 在 Excel 里准备好一张表：第 1 行写表头（A1 姓名、B1 部门、C1 地区……），第 2 行起每行一条数据，部门列里至少有几行填「销售」方便测试。
2. 按 Alt + F11 打开 VBA 编辑器，点菜单「插入」→「模块」，把上面的代码整段粘进去。
3. 回到 Excel，点一下你的数据表让它成为「当前表」，按 Alt + F8，选中「一键筛选_固定条件」，点「运行」。
4. 程序会自动建一张「销售名单」表，里面只有部门为「销售」的那些行；原表所有行重新显示，数据一个字没改。
5. 想换别的部门？把代码里的 Criteria1:="销售" 改成 Criteria1:="市场" 再运行即可。

小提示：Field:=2 的意思是「按区域里的第 2 列筛选」，因为我们的筛选是从 A1 开始的，所以第 2 列就是 B 列（部门）。SpecialCells(xlCellTypeVisible) 就是「只挑现在看得见的格子」——被筛选藏起来的行它一概不要。

案例二（中等）：运行时输入关键字和列号，按你给的条件筛选

功能说明 案例一的条件写死在代码里。这个案例改成：运行后弹两个框，让你输入「要按第几列筛」和「筛什么关键字」，比如列号填 3、关键字填「华南」，就按第 3 列等于「华南」来筛。这样同一段代码能筛任意列、任意值，不用每次改代码。新表命名为「筛选结果」，万一重名会自动换个名字，不会报错。

代码

Sub 一键筛选_输入关键字()    ' 运行时输入：要按第几列筛 + 筛什么关键字，结果复制到新建表    Dim 源表 As Worksheet    Dim 新表 As Worksheet    Dim 关键字 As String    Dim 列号 As Long    Dim 新表数据行 As Long    Set 源表 = ActiveSheet    关键字 = InputBox("请输入要筛选的关键字（例如：销售）：", "自动筛选")    If 关键字 = "" Then        MsgBox "没输入关键字，已取消。", vbInformation        Exit Sub    End If    列号 = Val(InputBox("要按第几列筛选？（部门在第2列就填 2）：", "选择列"))    If 列号 = 0 Then        MsgBox "列号没填对，已取消。", vbInformation        Exit Sub    End If    If 源表.AutoFilterMode Then 源表.AutoFilterMode = False    源表.Range("A1").AutoFilter Field:=列号, Criteria1:=关键字    Set 新表 = Sheets.Add(After:=Sheets(Sheets.Count))    ' 表名若已存在就自动加时间后缀，避免重名报错    On Error Resume Next    新表.Name = "筛选结果"    If Err.Number <> 0 Then        新表.Name = "筛选结果" & Format(Now, "hhmmss")        Err.Clear    End If    On Error GoTo 0    源表.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _        Destination:=新表.Range("A1")    源表.AutoFilterMode = False    新表.Columns.AutoFit    新表数据行 = 新表.Cells(新表.Rows.Count, 1).End(xlUp).Row - 1    If 新表数据行 <= 0 Then        MsgBox "没有找到符合「第" & 列号 & "列=" & 关键字 & "」的行。", vbExclamation    Else        MsgBox "已筛选出 " & 新表数据行 & " 行，复制到新表。", vbInformation    End IfEnd Sub

操作步骤

1. 把代码粘进同一个模块（和案例一放在一起也行）。
2. 回到 Excel，点一下数据表让它成为「当前表」，按 Alt + F8 运行「一键筛选_输入关键字」。
3. 第一个框输入要筛的关键字（比如「华南」），点「确定」；第二个框输入按第几列筛（比如地区在第 3 列就填 3），点「确定」。
4. 程序按你给的列和关键字筛选，把结果复制到新建的「筛选结果」表，最后提示复制到了几行。
5. 两个框任意一个留空、或列号填成 0，程序会提示「已取消」并自动停下，不会乱筛。

关键点：InputBox 弹出的文字先用 关键字 存起来，再用 Criteria1:=关键字 当成筛选条件；列号 同理通过 Field:=列号 指定列。整段逻辑和案例一完全一样，只是条件由你运行时临时给。

案例三（实用小案例）：两个条件组合筛选，复制后原表数据不动

功能说明 真实需求常常要「同时满足两个要求」，比如「部门=销售 且 地区=华南」。这个案例让你分别输入两个条件，程序在同一个区域上连着设两次筛选（第一次按部门、第二次按地区），Excel 会自动把「两个都符合」的行留下来，其余行藏起；再把看得见的行复制到新表。最后清掉筛选——原表所有行重新显示，而且任何单元格的值都没被修改，原表原封不动。

代码

Sub 一键筛选_多条件组合()    ' 输入两个条件（如 部门 + 地区），只复制同时满足两项的行到新表    ' 结束后清除筛选，原表数据完全不动    Dim 源表 As Worksheet    Dim 新表 As Worksheet    Dim 部门 As String    Dim 地区 As String    Dim 新表数据行 As Long    Set 源表 = ActiveSheet    部门 = InputBox("请输入要筛选的部门（例如：销售）：", "条件一")    If 部门 = "" Then MsgBox "已取消。", vbInformation: Exit Sub    地区 = InputBox("请输入要筛选的地区（例如：华南）：", "条件二")    If 地区 = "" Then MsgBox "已取消。", vbInformation: Exit Sub    If 源表.AutoFilterMode Then 源表.AutoFilterMode = False    ' 两个条件一起上：部门=某值 且 地区=某值（连着设两次即可组合）    源表.Range("A1").AutoFilter Field:=2, Criteria1:=部门    源表.Range("A1").AutoFilter Field:=4, Criteria1:=地区    Set 新表 = Sheets.Add(After:=Sheets(Sheets.Count))    On Error Resume Next    新表.Name = "组合筛选结果"    If Err.Number <> 0 Then        新表.Name = "组合筛选结果" & Format(Now, "hhmmss")        Err.Clear    End If    On Error GoTo 0    源表.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _        Destination:=新表.Range("A1")    ' 还原原表：关掉筛选，所有行重新显示，数据一字未改    源表.AutoFilterMode = False    新表.Columns.AutoFit    新表数据行 = 新表.Cells(新表.Rows.Count, 1).End(xlUp).Row - 1    If 新表数据行 <= 0 Then        MsgBox "没有同时满足两个条件的行。原表已还原。", vbExclamation    Else        MsgBox "已筛选出同时满足「部门=" & 部门 & " 且 地区=" & 地区 & _               "」的 " & 新表数据行 & " 行，复制到新表。原表数据未改动。", vbInformation    End IfEnd Sub

操作步骤

1. 把代码粘进模块（和前两个可以放在同一个模块里）。建议数据表至少有「部门（B列）」「地区（D列）」两列，并准备几行「部门=销售 且 地区=华南」的数据做测试。
2. 点一下数据表让它成为「当前表」，按 Alt + F8 运行「一键筛选_多条件组合」。
3. 第一个框输入部门（比如「销售」），第二个框输入地区（比如「华南」）。
4. 程序只把「部门是销售、同时地区是华南」的行复制到新建的「组合筛选结果」表；原表筛选被清除、所有行重新显示，数据没有任何改动。
5. 如果两个条件凑不出任何行，会提示「没有同时满足两个条件的行」，原表也照常还原，不会留下半成品。

关键经验（来自网络实战总结）：

• AutoFilter 是「藏」不是「删」：不匹配的行只是被隐藏，值还在；普通 .Copy 会把它们也带走，所以一定要用 SpecialCells(xlCellTypeVisible) 只复制看得见的。
• 先清旧筛选：动手前 If 源表.AutoFilterMode Then 源表.AutoFilterMode = False，避免旧条件干扰。
• 组合条件 = 连着设两次：对同一区域再调一次 .AutoFilter 指定另一列，就是「且」的关系。
• 原表不动的秘诀：我们只复制可见行到新表，从不修改原表单元格，最后 AutoFilterMode = False 让原表全部显示——数据始终原封不动。
• 别漏了表头：CurrentRegion 从 A1 起包含了表头，复制时表头会一起过去，新表才完整。
• 保存工作簿一定要存成 .xlsm 格式，否则宏会丢失。

知识点小结

用 VBA 按条件筛选并复制数据，本质上就是把「手动点筛选箭头、肉眼挑行、复制粘贴」这件事，翻译成四步固定动作：某列设条件（AutoFilter）→ 只复制看得见的行（SpecialCells）→ 粘到新建表（Sheets.Add）→ 清掉筛选恢复原表（AutoFilterMode = False）。三句话记牢就够用：

1. 设筛选 → Range("A1").AutoFilter Field:=列号, Criteria1:="条件"，Field 是从 A1 算起的第几列；
2. 只取可见 → .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=新表.Range("A1")，这是「藏起来的行不被复制」的关键；
3. 组合与还原 → 连着设两次 AutoFilter 就是「且」的关系，做完用 AutoFilterMode = False 关掉筛选，原表数据永远不动。

它和前面学的「合并多表」「导出 PDF」「循环群发」是一套组合拳：合并管「把分散的聚起来」、筛选管「把想要的挑出来」、PDF 管「成果交出去」、群发管「送到每个人」——从收数、挑数、到出成品，全程不用手动点一下。

【SVG 示意图】 

下一篇预告：筛选挑出想要的行之后，常常还要「把没用的那些行一次性删掉」。下一篇我们继续从网络上抓取新的 VBA 实用技巧，带你解锁「一键按条件批量删除行」——同样用 AutoFilter 把目标行留出来，再一键清掉，表格瞬间清爽。

【往期 VBA 精选】

系列已更新 60+ 篇，挑几篇最实用的继续看：

• 从0学 Excel VBA 第1篇：认识 VBA，什么是宏？^[1]
• 进销存实战第1篇：系统设计与初始化^[2]
• CRM 客户管理第1篇：系统设计与初始化^[3]
• Excel 一键系列：用 VBA 把表格批量导出成 PDF^[4]
• 界面自定义第1篇：自定义菜单与工具栏^[5]

关注公众号「西哥的AI幻觉」，对话框发送「VBA」可获取完整目录与配套源码。

【西哥能帮你做什么】

办公自动化 · AI 视频生产 · AI 编程助手落地 · 工厂数字化

• 把 Excel / VBA / Python 里那些重复到吐的活，一次性自动化掉
• 批量产出「古诗每日一诵」式 AI 古诗词视频（配音 + 配图 + 合成一键完成）
• OpenClaw / WorkBuddy 等 AI 编程助手的企业内训与落地陪跑
• 从 PLC 到 MES 的工厂务实数字化方案

【找到我】

• 公众号「西哥的AI幻觉」：点文章右上角「···」设为星标，更新不迷路
• 加微信：LekonWang（备注「VBA」进学习交流群）

本文由西哥原创，转载请注明出处「西哥的AI幻觉」。

引用链接