- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2012-1-3 13:45
| 只看該作者
回復 1# yagami12th
檔案中只需處裡 工作表1,工作表2,工作表3, 不需要{選擇權整理格式] [2011_1_6900]- Const ThePath = "d:\You\" '指定存放的主資料夾
- Sub Ex()
- Dim d As Object, SavePath As String, Sh As Worksheet, R As Variant, E As Variant, Newbook As Workbook
- Dim MonPath As String, 選擇權 As String, 履約價 As String
- Application.DisplayAlerts = False '停止系統 的提示
- Application.ScreenUpdating = False '停止螢幕更新功能
- Set d = CreateObject("scripting.Dictionary") '建立字典物件
- SavePath = Dir(ThePath, 16) '傳回指定存放的主資料夾
- If SavePath = "" Then MkDir (ThePath) '如主資料夾不存在 建立它
- For Each Sh In Sheets
- d.RemoveAll '字典物件 清空子物件
- With Sh '依序處裡 每一工作表
- For Each R In .Range(.[D2], .[D2].End(xlDown)) '每一工作表中在d欄
- d(R.Value) = "" '字典物件 設立子物件(履約價)
- Next
- MonPath = Mid(.[c2], 1, 4) & "_" & Mid(.[c2], 5) '月資料夾
- SavePath = Dir(ThePath & MonPath, 16) '尋找月資料夾
- If SavePath = "" Then MkDir (ThePath & MonPath) '如月資料夾不存在 建立它
- For Each E In Array("買權", "賣權") '依選擇權
- 選擇權 = "\" & MonPath & IIf(E = "買權", "_C\", "_P\") '月資料夾\選擇權資料夾
- SavePath = Dir(ThePath & MonPath & 選擇權, 16)
- If SavePath = "" Then MkDir (ThePath & MonPath & 選擇權)
- For Each R In d.KEYS '字典物件 依序處裡子物件 R (履約價)
- .AutoFilterMode = False '工作表中取消自動篩選
- .Range("A1").AutoFilter Field:=4, Criteria1:=R, Field:=5, Criteria1:=E
- 'AutoFilter 方法[自動篩選] 篩選出一個清單。
- 'Field:=4 第4欄 (履約價) ,Criteria1:=R 準則=R (履約價)
- 'Field:=5 第5欄 (選擇權) ,Criteria1:=E 準則=E (選擇權)
- 履約價 = Mid(.[c2], 1, 4) & "_" & Mid(.[c2], 5) & "_" & R & IIf(E = "買權", "_C", "_P")
- SavePath = ThePath & MonPath & 選擇權 & 履約價 '存檔的完整路徑名稱
- Set Newbook = Workbooks.Add(1) '新開檔案(1頁)
- .UsedRange.SpecialCells(xlCellTypeConstants).Copy Newbook.Sheets(1).[a1]
- '自動篩選的資料 複製到新開檔案第1頁的.[a1]
- Newbook.Close True, SavePath '新開檔案關閉 存檔
- Next
- Next
- .AutoFilterMode = False '離開工作表恢復原狀
- End With
- Next
- Application.DisplayAlerts = True '恢復系統的提示
- Application.ScreenUpdating = True '螢幕更新功能是開啟的則為 True。
- MsgBox "工作完成"
- End Sub
|
|
發表於 2012-1-3 18:55
| 
