用户:Hycheun3
Sub FilterAndGroupCategories()
'--------------------------------------------------
' 变数宣告区
'--------------------------------------------------
Dim wsSource As Worksheet ' 源工作表
Dim wsDest As Worksheet ' 目标工作表
Dim rngData As Range ' 数据范围
Dim lastRow As Long ' 最后一行
Dim categories() As Variant ' 分类规则阵列
Dim i As Integer ' 回圈计数器
Dim j As Integer ' 内部回圈计数器
Dim sheetName As String ' 工作表名称
'--------------------------------------------------
' 设定分类规则（工作表名称 + 筛选条件）
'--------------------------------------------------
categories = Array( _
Array("sio", "sio"), _ ' sio 类别 → sio 工作表
Array("io", "io"), _ ' io 类别 → io 工作表
Array("cia", "cia"), _ ' cia 类别 → cia 工作表
Array("sia_ia", "sia", "ia") _ ' sia 或 ia → sia_ia 工作表
)
'--------------------------------------------------
' 设定源工作表（当前活动工作表）
'--------------------------------------------------
Set wsSource = ActiveSheet
'--------------------------------------------------
' 找到最后一行（A 列的最后一个非空单元格）
'--------------------------------------------------
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'--------------------------------------------------
' 设定数据范围（A 到 G 列，含标题）
'--------------------------------------------------
Set rngData = wsSource.Range("A1:G" & lastRow) ' 7 列数据
'--------------------------------------------------
' 关闭屏幕更新和自动计算（提升效能）
'--------------------------------------------------
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'--------------------------------------------------
' 遍历每个分类，进行筛选与复制
'--------------------------------------------------
For i = LBound(categories) To UBound(categories)
sheetName = categories(i)(0) ' 取得工作表名称
'--------------------------------------------------
' 建立筛选条件阵列（排除工作表名称）
'--------------------------------------------------
Dim filterCriteria() As Variant
ReDim filterCriteria(1 To UBound(categories(i)))
For j = 1 To UBound(categories(i))
filterCriteria(j) = categories(i)(j) ' 填入筛选条件
Next j
'--------------------------------------------------
' 检查目标工作表是否存在
'--------------------------------------------------
On Error Resume Next
Set wsDest = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
'--------------------------------------------------
' 如果不存在，则新增工作表；否则清空内容
'--------------------------------------------------
If wsDest Is Nothing Then
Set wsDest = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsDest.Name = sheetName
Else
wsDest.Cells.Clear ' 清空现有内容
End If
'--------------------------------------------------
' 复制标题行（A1:G1）
'--------------------------------------------------
rngData.Rows(1).Copy wsDest.Range("A1")
'--------------------------------------------------
' 在 G 列（第 7 栏）进行筛选
'--------------------------------------------------
If UBound(filterCriteria) = 1 Then
' 单一条件筛选（如 sio、io、cia）
rngData.AutoFilter Field:=7, Criteria1:=filterCriteria(1)
Else
' 多条件筛选（如 sia 和 ia）
rngData.AutoFilter Field:=7, Criteria1:=filterCriteria, Operator:=xlFilterValues
End If
'--------------------------------------------------
' 检查是否有可见数据（排除标题行）
'--------------------------------------------------
On Error Resume Next
Dim visibleRows As Long
visibleRows = rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If visibleRows > 0 Then
' 复制可见数据（从 A2 开始）
rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, rngData.Columns.Count).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A2")
End If
On Error GoTo 0
'--------------------------------------------------
' 移除筛选
'--------------------------------------------------
wsSource.AutoFilterMode = False
'--------------------------------------------------
' 自动调整 A 到 G 列的宽度
'--------------------------------------------------
wsDest.Columns("A:G").AutoFit
'--------------------------------------------------
' 重置 wsDest 变数，准备下一个回圈
'--------------------------------------------------
Set wsDest = Nothing
Next i
'--------------------------------------------------
' 恢复 Excel 设定
'--------------------------------------------------
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'--------------------------------------------------
' 返回源工作表
'--------------------------------------------------
wsSource.Activate
'--------------------------------------------------
' 显示完成讯息
'--------------------------------------------------
MsgBox "数据已按类别分组完成：" & vbCrLf & _
"- sio → sio工作表" & vbCrLf & _
"- io → io工作表" & vbCrLf & _
"- cia → cia工作表" & vbCrLf & _
"- sia和ia → sia_ia工作表", vbInformation
End Sub