GBKEE

回復 1# yagami12th

->   用你這裡發文的檔案  執行此程式

1. Const ThePath = "d:\You\" '指定存放的主資料夾
   
2. Sub Ex()
   
3. Dim d As Object, SavePath As String, Sh As Worksheet, R As Variant, E As Variant, Newbook As Workbook
   
4. Dim MonPath As String, 選擇權 As String, 履約價 As String
   
5. Application.DisplayAlerts = False '停止系統 的提示
   
6. Application.ScreenUpdating = False '停止螢幕更新功能
   
7. Set d = CreateObject("scripting.Dictionary") '建立字典物件
   
8. SavePath = Dir(ThePath, 16) '傳回指定存放的主資料夾
   
9. If SavePath = "" Then MkDir (ThePath) '如主資料夾不存在 建立它
   
10. For Each Sh In Sheets
    
11. d.RemoveAll '字典物件 清空子物件
    
12. With Sh '依序處裡 每一工作表
    
13. For Each R In .Range(.[D2], .[D2].End(xlDown)) '每一工作表中在d欄
    
14. d(R.Value) = "" '字典物件 設立子物件(履約價)
    
15. Next
    
16. MonPath = Mid(.[c2], 1, 4) & "_" & Mid(.[c2], 5) '月資料夾
    
17. SavePath = Dir(ThePath & MonPath, 16) '尋找月資料夾
    
18. If SavePath = "" Then MkDir (ThePath & MonPath) '如月資料夾不存在 建立它
    
19. For Each E In Array("買權", "賣權") '依選擇權
    
20. 選擇權 = "\" & MonPath & IIf(E = "買權", "_C\", "_P\") '月資料夾\選擇權資料夾
    
21. SavePath = Dir(ThePath & MonPath & 選擇權, 16)
    
22. If SavePath = "" Then MkDir (ThePath & MonPath & 選擇權)
    
23. For Each R In d.KEYS '字典物件 依序處裡子物件 R (履約價)
    
24. .AutoFilterMode = False '工作表中取消自動篩選
    
25. .Range("A1").AutoFilter Field:=4, Criteria1:=R
    
26. .Range("A1").AutoFilter Field:=5, Criteria1:=E
    
27. 'AutoFilter 方法[自動篩選] 篩選出一個清單。
    
28. 'Field:=4 第4欄 (履約價) ,Criteria1:=R 準則=R (履約價)
    
29. 'Field:=5 第5欄 (選擇權) ,Criteria1:=E 準則=E (選擇權)
    
30. 履約價 = Mid(.[c2], 1, 4) & "_" & Mid(.[c2], 5) & "_" & R & IIf(E = "買權", "_C", "_P")
    
31. SavePath = ThePath & MonPath & 選擇權 & 履約價 '存檔的完整路徑名稱
    
32. Set Newbook = Workbooks.Add(1) '新開檔案(1頁)
    
33. .UsedRange.SpecialCells(xlCellTypeConstants).Copy Newbook.Sheets(1).[a1]
    
34. '自動篩選的資料 複製到新開檔案第1頁的.[a1]
    
35. With Newbook.Sheets(1)
    
36. .[O1] = "高價減低價"
    
37. .[P1] = "成交量變化"
    
38. With .[O2].Resize(.UsedRange.Columns(1).Rows.Count - 1) '在這範圍
    
39. .Cells = "=RC[-8]-RC[-7]" '然後在O2欄位=g2-h2: 制訂公式
    
40. .Value = .Value '取值 -> 消除公式
    
41. End With
    
42. With .[P3].Resize(.UsedRange.Columns(1).Rows.Count - 2)
    
43. .Cells = "=RC[-6]-R[-1]C[-6]" '在p3格位輸入公式=j3-j2
    
44. .Value = .Value
    
45. End With
    
46. End With
    
47. Newbook.Close True, SavePath '新開檔案關閉 存檔
    
48. Next
    
49. Next
    
50. .AutoFilterMode = False '離開工作表恢復原狀
    
51. End With
    
52. Next
    
53. Application.DisplayAlerts = True '恢復系統的提示
    
54. Application.ScreenUpdating = True '螢幕更新功能是開啟的則為 True。
    
55. MsgBox "工作完成"
    
56. End Sub

複製代碼

GBKEE

回復 3# yagami12th
台語俚語 : 戲棚下站久是你的
我沒什麼經驗,功力是在這裡練習的 (多看多問多練習)

1. Sub Ex()
   
2.     Dim D As Object, AR(), E As Variant
   
3.     Set D = CreateObject("SCRIPTING.DICTIONARY")
   
4.     AR = Array("AA", "BB", "CC", "DD")
   
5.     For Each E In AR
   
6.         D(Mid(E, 1, 1)) = E
   
7.     Next
   
8.     For Each E In D.KEYS
   
9.         MsgBox E
   
10.     Next
    
11.     MsgBox Join(D.KEYS, ":")
    
12.     For Each E In D.ItemS
    
13.         MsgBox E
    
14.     Next
    
15.     MsgBox Join(D.ItemS, ":")
    
16. End Sub

複製代碼

下載 (49.46 KB)

2012-1-8 15:23