User: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