- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 1# handsometrowa
資料區域 變成紅色的字樣 ,錄製巨集試試看- Option Explicit
- Dim Rng As Range, AR()
- Sub Main()
- AR = Array("到期月份", "履約價", "買賣權", "成交量", "未沖銷契約量")
- With Sheets("選擇權總表")
- .[L4:M4] = Array("成交量", "未沖銷契約量") '"*成交量" ,"*未沖銷'資料庫欄"*" 進階篩選有會有錯誤
- Set Rng = .Range("B4:Q" & .[B4].End(xlDown).Row) '資料庫
- 篩選程式 "分類一"
- 篩選程式 "賣權"
- 篩選程式 "買權"
- .Activate
- End With
- End Sub
- Private Sub 篩選程式(Sh As String) 'SH參數為字串型態 :工作表名稱
- Dim T As String
- With Sheets(Sh)
- .Cells.Clear '儲存格:清除
- .[L1].Value = AR(0) '進階篩選: CriteriaRange,準則欄位名稱("到期月份")
- .[A1:E1].Value = AR '進階篩選: CopyToRange,複製到儲存格的欄位名稱
-
- If Sh = "賣權" Or Sh = "買權" Then
- .[L1].Value = AR(2) '進階篩選: CriteriaRange,準則欄位名稱("買賣權")
- .[L2] = IIf(Sh = "買權", "Call", "Put") '進階篩選:準則欄位 設立條件
- End If
- Rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.[L1:L2], CopyToRange:=.[A1:E1], Unique:=True
- .[L1:L2] = "" 'Unique:=True 僅篩選唯一的記錄
- If Sh <> "賣權" And Sh <> "買權" Then
- .Rows(2).Delete '資料庫第2列為 (週別) 不需要刪掉
- Else
- 月份契約篩選程式 Sh
- End If
- End With
- End Sub
- Private Sub 月份契約篩選程式(Sh As String)
- Dim R As Range
- On Error GoTo ER: '程式錯誤處裡:月份契約買權的工作表,如不存在會有錯誤.
- With Sheets(Sh)
- .Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
- '篩選 [到期月份]在工作表最右端的欄位
- For Each R In .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown)) '最右端的欄位的[到期月份]
- .Range("A1").AutoFilter Field:=1, Criteria1:=R '自動篩選: A欄 準則= [到期月份]
- .Range("A:E").Copy Sheets(R & Sh).[A1] '不符合準則的資料會隱藏掉
- Next
- End With
- Exit Sub '離開這程序
- ER:
- If Err.Number = 9 Then '月份契約買權的工作表
- Sheets.Add Sheets(Sheets.Count) '新增工作表
- ActiveSheet.Name = R & Sh '工作表:命名
- Resume '回到程式錯誤點
- End If
- MsgBox Err.Description & Err.Number '告知:不是工作表不存在會有錯誤.
- End Sub
|
|
發表於 2013-5-23 17:13
| 
