- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2014-10-7 11:28
| 只看該作者
回復 1# hero007
試試看- Option Explicit
- Sub Ex()
- Dim Sh As Worksheet, Rng As Range
- With Sheets("TOP10")
- Sheets("工作表1").Rows(1).Copy .Range("A1")
- .UsedRange.Offset(1) = ""
- .Activate
- End With
- Application.ScreenUpdating = False
- Set Rng = Sheets("工作表1").Cells(1, Sheets("工作表1").Columns.Count)
- Sheets("工作表1").Range("A:A").AdvancedFilter xlFilterCopy, , Rng, True
- 'AdvancedFilter(進階篩選): [商品類別]不重複的個項 到 Rng
- Rng.Sort Rng, xlAscending, Header:=xlYes 'Sort : 排序
- Set Sh = Sheets.Add '這活頁簿中新增工作表
- Set Rng = Rng.Offset(1) '下移一列
- Do While Rng <> ""
- With Sheets("工作表1")
- .Range("A1").AutoFilter 1, Rng 'AutoFilter(自動篩選): [商品類別]的準則= Rng
- .Range("A:E").Copy Sh.[A1] '自動篩選後的資料複製到新增工作表
- End With
- With Sh
- .Range("A1").AutoFilter Field:=4, Criteria1:="10", Operator:=xlTop10Items
- 'AutoFilter(自動篩選): [數量] 最大數值的前10項,
- '**準則 Criteria1:="15" -> 前15項 ***
- .UsedRange.Offset(1).Copy Sheets("TOP10").Range("A" & Sheets("TOP10").Rows.Count).End(xlUp).Offset(1)
- '最大數值的前10項複製到Sheets("TOP10")
- End With
- Set Rng = Rng.Offset(1) '下移一列
- Loop
- Sheets("工作表1").Cells.AutoFilter
- '工作表有自動篩選,在一次的自動篩選,可取消工作表上的自動篩選
- Rng.EntireColumn = ""
- Application.DisplayAlerts = False
- Sh.Delete
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
|
|
發表於 2014-10-6 16:24
| 
