misser wrote:
何不乾脆把程式碼變得更有「彈性」(通用)一點
說彈性，我2樓給的範例也很有彈性，跑一次就全分類好了
欄位也只要改一個字，看是要用inputbox，還是ActiveCell.Column…
至於，工作表另存獨立新檔案、工作表內容新增(複製)到舊檔案
用outlook寄信、工作表另存pdf…等等
之後只要加個副程式就行，而這些功能隨便google一下，就一大堆範例
只是樓主最後決定用同一頁切來切去的，所以該範例不適用
另外，發現您的範例有一個小bug，您可以試試先篩選a欄、再篩選b欄
misser wrote:
如果還要為每個表格手動操作樞紐分析表
不需要樞紐分析表的方法，請參考
只有更換欄位時，才更新篩選條件
可避免同欄位連續篩選時，因大量迴圈，造成效能降低的問題
Dim List_Index As Integer, Col_Old As Integer, Col_New As Integer, List()
Sub test2()
Col_New = ActiveCell.Column
If Cells(1, Col_New) = "" Then
List_Index = 0
Sheets("sheet1").Shapes("Bevel 5").TextFrame.Characters.Text = "請選擇任一有資料欄位" & Chr(13) & "(可選空白儲存格)"
Exit Sub
End If
Dim Source As Range, LastRow As Long, LastCol As Integer
LastRow = Sheets("sheet1").UsedRange.Rows.Count
LastCol = Sheets("sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
Set Source = Sheets("sheet1").Range(Sheets("sheet1").Cells(1, Col_New), Sheets("sheet1").Cells(LastRow, Col_New))
If Col_New = Col_Old Then
'use old list
Else
If Col_Old > 0 Then Sheets("sheet1").Range(Columns(1), Columns(LastCol)).AutoFilter Field:=Col_Old
Call Get_List(Source, LastRow)
Col_Old = Col_New
List_Index = 0
End If
If List_Index > UBound(List()) Then List_Index = 1 Else List_Index = List_Index + 1
Sheets("sheet1").Range(Columns(1), Columns(LastCol)).AutoFilter Field:=Col_New, Criteria1:=List(List_Index - 1, 0)
'注意：如果要用時間當篩選條件
'List(List_Index - 1, 0)需另外處理成和工作表相同的時間格式，才能正常篩選
'debug
Sheets("sheet1").Shapes("Bevel 5").TextFrame.Characters.Text = "test2：" & "欄位=" & Chr(96 + Col_New) & _
"，不重覆項目：" & UBound(List()) + 1 & "筆" & Chr(13) & _
List(List_Index - 1, 0) & "：篩選第" & List_Index & "筆，合計=" & List(List_Index - 1, 1) & "筆)"
End Sub
Sub Get_List(Source As Range, LastRow As Long)
Dim dic As Object, i As Long
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To LastRow
dic(Source(i, 1).Value) = dic(Source(i, 1).Value) + 1
Next i
ReDim List(dic.Count - 1, 1)
For i = 0 To dic.Count - 1
List(i, 0) = dic.keys()(i)
List(i, 1) = dic.items()(i)
Next i
Set dic = Nothing
End Sub
[點擊下載]
