Board logo

標題: 棘手的excel運算問題，如何改善?? [打印本頁]
作者: 藍天麗池    時間: 2016-1-26 14:15     標題: 棘手的excel運算問題，如何改善??

本帖最後由 藍天麗池 於 2016-1-26 14:18 編輯

[attach]23180[/attach]
[attach]23181[/attach]
附檔是一個小弟平常用在紀錄的excel目前有些棘手的運算問題還麻煩版上大大幫我一下

如圖所示，左邊是我平時在紀錄的儲存格，右邊是計算用的儲存格，但是因為右邊計算的儲存格裡面我有寫一些函數，造成整個excel在跑的時候左邊無法紀錄或是整個當掉(因為所寫函數太吃CPU和記憶體)，請問一下版上大大小的這個問題應該怎麼解決才好??

我有想出一些解決方式，無奈對VBA不是太熟，在煩請版上高手幫幫忙

解決方式
1.讓左邊A-F列即時運算(A2-F2是DDE所以需要隨時更新才能接收資料)，R-T列每分鐘運算一次，更新完後寫成值而不是公式，這樣的方式可以嗎??(不知道同一個sheet可不可以不同頻率即時運算)

2.變更R-T列的函數寫法，讓整個程式跑起來不要那麼吃資源

3.將S-T列的函數寫在VBA裡面，每分鐘執行一次執行完後將公式寫成值

煩請版上的高手大大幫幫小弟
作者: c_c_lai    時間: 2016-1-26 19:45

本帖最後由 c_c_lai 於 2016-1-26 20:00 編輯

回復 1# 藍天麗池
在 shtRTD (RTD) 表單內 RecordPrice()
加入 STSumifs WR, WR， 如下：
  1. Option Explicit

  3. Sub RecordPrice()
  4.     Dim WR As Long
  5.     Dim I As Byte

  7.     If Range("P2") < 1 Then Exit Sub

  9.     WR = Range("A1").End(xlDown).Row + 1
  10.     '  ActiveWindow.ScrollRow = WR - 5     '  只顯示最新幾筆資料
  11.     If (WR = 3) Or _
  12.             (Range("F" & WR - 1) <> Range("F2")) Then   '  總量有異動時才記錄
  13.         For I = 1 To 6
  14.             Cells(WR, I) = Cells(2, I)
  15.         Next 'I
  16.         
  17.         STSumifs WR, WR                         '  資料同步將數值寫入到 R，S，T 三欄內
  18.     End If
  19.     '  With ActiveWindow
  20.         '  If Intersect(Cells(WR, "B"), .VisibleRange) Is Nothing Then .SmallScroll 5
  21.     '  End With
  22. End Sub

  24. Private Function STSumifs(ByVal endST As Long, Optional startST As Long = 3)
  25.     Dim cts As Long
  26.     Dim btm As Long
  27.    
  28.     btm = Range("A1").End(xlDown).Row
  29.    
  30.     For cts = startST To endST
  31.         Cells(cts, "R") = IIf(cts = 2, "", IIf(cts = 3, "=MAX(B3:B" & btm & ")", "=R" & (cts - 1) & "-1"))
  32.         Cells(cts, "R") = Cells(cts, "R").Value
  33.         Cells(cts, "S") = "=IF(SUMIFS($E3:$E" & btm & ",$D3:$D" & btm & ",S$1,$B3:$B" & btm & ",$R" & (cts - 1) & ")=0," & Chr(34) & Chr(34) & ",SUMIFS($E3:$E" & btm & ",$D3:$D" & btm & ",S$1,$B3:$B" & btm & ",$R" & (cts - 1) & "))"
  34.         Cells(cts, "S") = Cells(cts, "S").Value
  35.         Cells(cts, "T") = "=IF(SUMIFS($E3:$E" & btm & ",$D3:$D" & btm & ",T$1,$B3:$B" & btm & ",$R" & (cts - 1) & ")=0," & Chr(34) & Chr(34) & ",SUMIFS($E3:$E" & btm & ",$D3:$D" & btm & ",T$1,$B3:$B" & btm & ",$R" & (cts - 1) & "))"
  36.         Cells(cts, "T") = Cells(cts, "T").Value
  37.     Next cts
  38. End Function

  40. Sub Test()
  41.     Dim WR As Long
  42.    
  43.     WR = Range("A1").End(xlDown).Row
  44.     STSumifs WR
  45. End Sub
複製代碼
最後面之 Test() 是可讓你一次自動執行更換 第 3 行 ~ 第 4903 行
R，S，T 三欄的資料值。如果不異動的話，就不需執行它。
其它程式部分均保留原貌。因我無券商連線無法測知狀況。
作者: jackyq    時間: 2016-1-26 19:51

本帖最後由 jackyq 於 2016-1-26 19:55 編輯

1, 3 方法可行
R-T列的需求每分鐘才運算一次
卻變成逐筆運算
甚至還逐歷史
不慢都難
作者: 准提部林    時間: 2016-1-26 21:29

SUMIFS , 算來就慢, 何況全欄引用！！！

加兩個輔助欄公式：
Ｇ２：=IF($D2=S$1,$E2,"-")　右拉Ｈ２，下拉到底
Ｓ３：=SUMIF($B:$B,$R2,G:G)　右拉Ｔ３，下拉到底，儲存格格式自訂為：#　（０值不顯示）

另外，時間公式改如下：
Ｄ２：=--TEXT(A2,"hhmm")
Ｓ１：=--TEXT(S2,"hhmm")
Ｔ１：=--TEXT(T2,"hhmm")
作者: c_c_lai    時間: 2016-1-27 09:29

回復 1# 藍天麗池
請參考：
如何把個股每 5 分鐘的成交價格記錄下來？
作者: 藍天麗池    時間: 2016-1-27 09:38

回復 2# c_c_lai
執行後有幾個問題跟C大說一下
1.R列因為會跟著指數創新高而改變所以不能是寫死的

2.R列只需要抓最高到最低區間200個左右，不需要一直向下增加

3.執行後S跟T列沒有任何動作

另外，如果我想在S列之後呈現8:45-13:45之間的所有結果這樣的話公式要怎麼改(意思就是S寫入8:45、T寫入8:46....一直寫到13:45)
PS.我看了一下用R1C1的方式寫公式好像就不用變更
=IF(SUMIFS(C5,C4,R1C,C2,R[-1]C18)=0,"",SUMIFS(C5,C4,R1C,C2,R[-1]C18))---每一行都這樣，這樣如果要寫到13:45分就應該不用輸入太多公式了

C大我的想法是這樣你看看可不可行
R列不動，S列在8:46:01-8:46:05之內寫入公式，5秒內甚至更短時間完成計算，之後將公式寫成值，T、U、V列依此類推(就是讓執行時間不要太久，執行完立刻將公式寫成值)
這只是小弟的一個想法，還請C大看看可不可行
作者: c_c_lai    時間: 2016-1-27 11:51

回復 6# 藍天麗池
說真的，我不太懂 SUMIFS 的用意，只是依樣畫葫。
如你有時間的話，稍稍說明一下它的使用方式與你的想法，
如此會更明瞭其作用，謝謝。
作者: 准提部林    時間: 2016-1-27 12:43

回復 6# 藍天麗池


8:45-13:45 = ３００分鐘　
R列只需要抓最高到最低區間200個左右　

300*200 個SUMIFS，跑得動嗎？？？
作者: 准提部林    時間: 2016-1-27 13:49

做個副程式，固定時間去 CALL 即可，
欄位不夠，只做到 08:45 ~ 12:00 共 196 欄，自行去調整：
　
Sub 統計()
Dim R&, C&, Arr, Brr(1 To 200, 1 To 196), uMax, i&
R = Cells(Rows.Count, 1).End(xlUp).Row
If R < 2 Then Exit Sub
Arr = Range("A2:E" & R).Value
uMax = [R3] '最大成交數
For i = 1 To UBound(Arr)
　　R = uMax - Arr(i, 2) + 1  '最大成交數 - Ｂ欄成交數 + 1 = 列位
　　If R < 1 Or R > 200 Then GoTo 101
    　
　　C = Int(Arr(i, 1) * 1440) - 524 'Ａ欄時間分鐘數 - 8:44分鐘數 = 欄位
　　If C < 1 Or C > 196 Then GoTo 101
    　
　　Brr(R, C) = Brr(R, C) + Arr(i, 5)
101: Next
[S3].Resize(200, 196) = Brr
Beep
End Sub

參考檔：
[attach]23188[/attach]
　
作者: 藍天麗池    時間: 2016-1-27 13:55

本帖最後由 藍天麗池 於 2016-1-27 14:01 編輯

回復 7# c_c_lai

C大我說明一下，我的主要用意是左邊紀錄量，右邊我根據時間和不同的成交點位來加總
例如：
12:58:55        7775        1        1258        -1                                             
12:58:56        7776        1        1258        -1
12:58:56        7776        1        1258        -1
12:58:58        7775        25        1258        1
12:58:58        7775        1        1258        -1
12:58:58        7775        1        1259        -1
12:59:00        7774        4        1259        -1
12:59:00        7774        1        1259        -1
12:59:00        7774        1        1259        -1
12:59:01        7775        1        1259        -1
12:59:01        7774        1        1259        -1
12:59:02        7774        1        1259        -1
12:59:02        7774        5        1259        -1
12:59:03        7774        12        1259        1

右邊是將12:58裡面的所有7775、7776、7774的量加總，但不加總12:58分以外的量，這就是我為什麼用SUMIFS的原因，如果用SUMIF則會將當天所有同價位或同時間的數字都加總，而我要的只是某個時間段裡面有出現的價位的加總
如上所示
7776  -2        12:58分裡面7776出現2次，最後面的數字加總是-2
7775  -3        12:58分裡面7775出現3次，最後面的數字加總是-3
7774   0         12:58分裡面7774出現0次，最後面的數字加總是0
大概就是這樣，C大能理解嗎??
作者: 藍天麗池    時間: 2016-1-27 13:58

回復 8# 准提部林
所以函數不能直接打在儲存格上面，要用VBA且執行完要馬上將公式轉成值，要不然一樣會拖慢速度
作者: 藍天麗池    時間: 2016-1-27 13:59

回復 9# 准提部林

大大可以說明一下用法和原理嗎??我看不太懂，抱歉
謝謝你的幫忙
作者: 藍天麗池    時間: 2016-1-27 14:10

回復 9# 准提部林

大大好厲害，但請教一下
1.是每分鐘都要自己按統計嗎??
2.按統計的過程中會造成EXCEL變慢嗎??
3.如果把它改成自動每分鐘統計一次可以嗎??
作者: 藍天麗池    時間: 2016-1-27 14:14

回復 7# c_c_lai


    C大我要的效果大概跟7樓大大的附件一樣你看一下
作者: c_c_lai    時間: 2016-1-27 15:30

本帖最後由 c_c_lai 於 2016-1-27 15:31 編輯

回復 12# 藍天麗池
這是你原本的定義：
  1. S3
  2. =IF(SUMIFS($E:$E,$D:$D,S$1,$B:$B,$R2)=0,"",SUMIFS($E:$E,$D:$D,S$1,$B:$B,$R2))
  3. T3
  4. =IF(SUMIFS($E:$E,$D:$D,T$1,$B:$B,$R2)=0,"",SUMIFS($E:$E,$D:$D,T$1,$B:$B,$R2))
複製代碼
這是程式碼解析的結果：
  1. S3
  2. =IF(SUMIFS($E3:$E4903,$D3:$D4903,S$1,$B3:$B4903,$R2)=0,"",SUMIFS($E3:$E4903,$D3:$4903,S$1,$B3:$B4903,$R2))
  3. T3
  4. =IF(SUMIFS($E3:$E4903,$D3:$D4903,T$1,$B3:$B4903,$R2)=0,"",SUMIFS($E3:$E4903,$D3:$D4903,T$1,$B3:$B4903,$R2))
複製代碼
然後再轉為數值表示。
作者: c_c_lai    時間: 2016-1-27 16:06

本帖最後由 c_c_lai 於 2016-1-27 16:15 編輯

回復 14# 藍天麗池
Function STSumifs(ByVal endST As Long, Optional startST As Long = 3)
1.  Optional startST As Long = 3 的用意，事先賦予預設值；
    例如:
    Sub Test()
        Dim WR As Long
   
        WR = Range("A1").End(xlDown).Row   '  最後一筆資料列
        STSumifs WR
    End Sub
    在 STSumifs 的函式中：
        For cts = startST To endST
    startST 等於 3， endST  等於 WR (4903)
    此時 STSumifs WR = STSumifs WR, 3 之意，
    Optional  的變數宣告，如未帶入值，則以其
   設定的預設值 (3) 為參數值。
    ***  這是一次就處理 3 ~ 4903 完畢。
     
2.  假設帶入值為：
    WR = Range("A1").End(xlDown).Row + 1 '  最後一筆資料列 + 1
    STSumifs WR, WR
    startST 等於 WR， endST  等於 WR (4094)
    ***  這是將資料寫入到資料錄的最後列。
作者: 藍天麗池    時間: 2016-1-27 17:04

回復 16# c_c_lai

哈哈，有點複雜，看不太懂，不過還是謝謝C大，我明天先來測試提大的看看
作者: 准提部林    時間: 2016-1-27 21:17

大概做個每分鐘〔自動統計〕，不足之處自行調整，
若與自動記錄ＤＤＥ有衝突時，也請自行去排除！！
　
[attach]23189[/attach]
作者: 藍天麗池    時間: 2016-1-28 08:50

回復 18# 准提部林
準大，我測試了一下昨天那個手動的版本，發現價格無法自動記錄了，可以請准大幫幫忙嗎??
小弟簡單的可以，但是這對小弟來說已經超出能力範圍了，感謝
作者: 藍天麗池    時間: 2016-1-28 08:51

回復 16# c_c_lai

C大，昨天7樓的附件經測試後無法記錄價格，可以請C大幫我看看嗎??
作者: c_c_lai    時間: 2016-1-28 10:41

本帖最後由 c_c_lai 於 2016-1-28 10:48 編輯

回復 20# 藍天麗池
你說的 "昨天7樓的附件經測試後無法記錄價格"，
7樓 那來的附件？
你指的是？
  1. Sub RecordPrice()
  2.     Dim WR As Long
  3.    Dim I As Byte

  5.    If Range("P2") < 1 Then Exit Sub
  6.     WR = Range("A1").End(xlDown).Row + 1
  7.    '  ActiveWindow.ScrollRow = WR - 5     '  只顯示最新幾筆資料
  8.     If (WR = 3) Or _
  9.            (Range("F" & WR - 1) <> Range("F2")) Then   '  總量有異動時才記錄

  11. .        For I = 1 To 6
  12.             Cells(WR, I) = Cells(2, I)
  13.        Next 'I
  14.         STSumifs WR, WR                         '  資料同步將數值寫入到 R，S，T 三欄內
  15.   End If
  16.    '  With ActiveWindow
  17.         '  If Intersect(Cells(WR, "B"), .VisibleRange) Is Nothing Then .SmallScroll 5
  18.     '  End With
  19. End Sub
複製代碼
你的程式碼中有加入這一行嗎？
  1. STSumifs WR, WR                         '  資料同步將數值寫入到 R，S，T 三欄內
複製代碼
你的原始碼是在 Workbook_Calculate() 裡執行的，
請檢查一下。
准提部林版大的分享亦值得你研究參考，你想要的答案
是不是那樣？
我的程式碼 STSumifs() 只是將你本來之公式 (Formula) 以程式模式與資料同步寫入
而已，沒做任何之延伸創意。因為我不懂你公式的作用。看了准提部林版大的分享
才稍稍明瞭你要的結果可能會是如此，還是另有想法？
作者: 藍天麗池    時間: 2016-1-28 12:16

本帖最後由 藍天麗池 於 2016-1-28 12:23 編輯

回復 21# c_c_lai

打錯，應該是9樓才對
C大說加那個是指你的程式吧，我面前用9樓的附件再跑沒加，就是價格無法紀錄
作者: c_c_lai    時間: 2016-1-28 12:57

回復 22# 藍天麗池
[attach]23193[/attach]
作者: 藍天麗池    時間: 2016-1-28 13:24

本帖最後由 藍天麗池 於 2016-1-28 13:31 編輯

回復 23# c_c_lai

C大我把它全部弄回去後，可以記錄，但卻不是我原本設定的變動才紀錄，為什麼會這樣??
[attach]23194[/attach]
現在沒變動也記錄，是哪邊出錯了嗎??
作者: c_c_lai    時間: 2016-1-28 13:35

回復 24# 藍天麗池
你把你目前的Excel檔案壓縮上傳，
眼見為憑！
作者: 藍天麗池    時間: 2016-1-28 13:44

回復 25# c_c_lai
[attach]23195[/attach]
兩個檔案，都是准大的一個手動，一個自動，抱歉應該早點上傳的
作者: c_c_lai    時間: 2016-1-28 14:06

回復 26# 藍天麗池
你說 "可以記錄，但卻不是我原本設定的變動才紀錄"
此話怎說？
你開啟檔案後，它會從 DDE 匯入即時數據，接著它便自動判斷
總量有異動時才記錄，這個過程不對嗎？"不是你原本設定的變動才紀錄"
是甚麼情形，因我沒券商的軟體所以無從得知差異在那裏。
作者: 藍天麗池    時間: 2016-1-28 14:10

本帖最後由 藍天麗池 於 2016-1-28 14:12 編輯

回復 27# c_c_lai


    看24樓截圖，F列在紀錄時相同也記錄了而且都是同樣資料，F42-F52都是相同的，但是他也記錄了，正常不應該是這樣
作者: c_c_lai    時間: 2016-1-28 14:43

回復 28# 藍天麗池
那你再觀察一下 F2 欄的數據有沒有一直在變動？
如沒，則你必須重新再次啟動券商的軟體。
作者: 准提部林    時間: 2016-1-28 16:56

回復 28# 藍天麗池


Private Sub Workbook_Open()
Call 統計_啟動
Application.RTD.ThrottleInterval = 0
Application.Calculation = xlCalculationManual   '開啟檔案就將〔自動重算〕關閉，怎可能觸動〔Calculate〕　
End Sub
作者: 藍天麗池    時間: 2016-1-28 17:14

回復 29# c_c_lai

有，一直有變動
作者: 藍天麗池    時間: 2016-1-28 17:15

回復 30# 准提部林


    準大，我不太懂你的意思
作者: c_c_lai    時間: 2016-1-28 18:24

回復 31# 藍天麗池
你把 ThisWorkbook 裡的函數內容稍加異動
然後予以儲存後，關閉重開 Excel：
  1. Option Explicit

  3. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  4.     Application.RTD.ThrottleInterval = 2000
  5.     Application.Calculation = xlCalculationAutomatic
  6. End Sub

  8. Private Sub Workbook_Open()
  9.     Application.RTD.ThrottleInterval = 0
  10.     Application.Calculation = xlCalculationManual
  11. End Sub
複製代碼
修改成：
  1. Option Explicit

  3. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  4.     Application.RTD.ThrottleInterval = 0
  5.     Application.Calculation = xlCalculationManual
  6. End Sub

  8. Private Sub Workbook_Open()
  9.     Application.RTD.ThrottleInterval = 2000
  10.     Application.Calculation = xlCalculationAutomatic
  11. End Sub
複製代碼
再重新試試看。
這便是准提部林版大問你的問題。
作者: 藍天麗池    時間: 2016-1-28 21:46

回復 33# c_c_lai


    可是之前這樣設定能跑，為什麼加了准大的程式之後就不能跑呢??
作者: c_c_lai    時間: 2016-1-29 07:34

本帖最後由 c_c_lai 於 2016-1-29 07:38 編輯

回復 34# 藍天麗池
我前前後後查看了你與准提部林版大上傳分享的檔案，
發現問題仍然出自於你的自行再整合，准提部林版大
上傳的內容都沒加入 Workbook_Open() 的執行內容，
甚至在第一次給的 Xl0000328.rar 也亦將它 Marked 掉，
你只將它分享模組內的 Sub 統計() 直接貼入到你原本的檔案內
所以才會造成未能正常執行的原因。為幫助你更能明瞭版大
模組的運作，特予在其模組內每一循環細部分析解說，希望你
能進一步學習到如何運用，同時能增進你本身的自我觀察力。
我將三方的程式模組予以組合上傳上來，你測試看看結果如何。
解壓後便直接用它來執行測試，如此才得以觀測其測試結論。
[attach]23203[/attach]
作者: 藍天麗池    時間: 2016-1-29 08:48

回復 35# c_c_lai

C大妳真是太細心了，感謝你，我先研究看看，謝謝
作者: c_c_lai    時間: 2016-2-1 08:30

回復 36# 藍天麗池
最近有點事耽擱了。
你在 #10 裡的說明，要的是？
[attach]23219[/attach]
作者: 藍天麗池    時間: 2016-2-1 09:58

回復 37# c_c_lai


    測試C大的檔案後，發現可能執行太多東西，DDE都不太會跳動了，之前1秒跳7-8次，現在2-3秒跳動一次
作者: c_c_lai    時間: 2016-2-1 11:17

回復 38# 藍天麗池
那你用我目前上傳的檔案來做測試看看。
測試完後告訴我一聲結果。
我先把准提部林版大分享的功能改為 統計A()，
先不予執行，而去執行我增加之測試模組
統計() ->dicStatics 你觀察看看進行順暢否？
[attach]23220[/attach]
作者: c_c_lai    時間: 2016-2-1 11:48

回復 38# 藍天麗池
  1. Sub 統計()        '  L、M、N、O 欄位統計
  2.     Dim DD As Date
  3.    
  4.     dicStatics
  5.     DD = Format(Now, "yyyy/mm/dd hh:mm")    '  DD = 2016/1/28 上午 12:41:00 : Date
  6.     TimeTxt = DD + 1 / 1440                 '  TimeTxt = 2016/1/28 上午 12:42:00 : Variant/Date
  7.     Application.OnTime TimeTxt, "統計"      '  每一分鐘自動再次執行一次。
  8. End Sub

  10. Sub dicStatics()
  11.     Dim txt As String, dic As Object, dic2 As Object, A As Range, sp As Variant

  13.     ' txt = [B2] & Left(CStr(Format([A2], "HH:MM:SS")), 5)
  14.     ' txt = [B2] & Left(CStr([A2]), 5)
  15.     '  MsgBox txt

  17.     Set dic = CreateObject("Scripting.Dictionary")
  18.     Set dic2 = CreateObject("Scripting.Dictionary")

  20.     For Each A In Range([A3], [A3].End(xlDown))
  21.         txt = A.Offset(, 1) & "," & Left(Format(A, "HH:MM:SS"), 5)
  22.         '  dic(txt) = IIf(IsEmpty(dic(txt)), A.Offset(, 4).Value + 1, dic(txt)) + A.Offset(, 4).Value
  23.         '  在 IsEmpty(dic(txt)) 判斷時， dic(txt) 會自動先賦予一次之 A.Offset(, 4).Value 值，然後再次
  24.         '  Assign 一次的 A.Offset(, 4).Value 值， 如 A.Offset(, 4).Value = -1，則結果會變成 -2。
  25.         '  是故改成如下方式，直接賦予一次之 A.Offset(, 4).Value 值，則結果便會變成 -1 (初始值設定)。
  26.         dic(txt) = dic(txt) + A.Offset(, 4).Value       '  次
  27.         dic2(txt) = dic2(txt) + A.Offset(, 2).Value     '  量
  28.     Next
  29.    
  30.     [M3].Resize(UBound(dic.Keys) + 1) = Application.Transpose(dic.Keys)                '  索引值就是 Keys
  31.     [N3].Resize(UBound(dic.Keys) + 1) = Application.Transpose(dic.Items)               '  資料內容就是 Items
  32.     [O3].Resize(UBound(dic2.Keys) + 1) = Application.Transpose(dic2.Items)               '  資料內容就是 Items
  33.    
  34.     With [M3].Resize(UBound(dic.Keys) + 1, 3)        '  Range("M3:M" & [M3].End(xlDown).Row)
  35.         .Cells.Sort Key1:=.Cells(1), Order1:=xlDescending, Header:=xlNo    '  xlAscending
  36.     End With
  37.    
  38.     For Each A In Range([M3], [M3].End(xlDown))
  39.         sp = Split(A, ",")
  40.         A.Offset(, -1) = sp(0)
  41.         A = sp(1)
  42.     Next
  43. End Sub
複製代碼
作者: 藍天麗池    時間: 2016-2-3 09:41

回復 40# c_c_lai


    可以記錄，但不可統計，C大謝謝，我想我還是改用API+EXCEL的方式進行好了，不用再費心了，真的非常的謝謝妳
作者: GBKEE    時間: 2016-2-3 09:49

本帖最後由 GBKEE 於 2016-2-3 10:34 編輯

回復 38# 藍天麗池

附檔試試看看另一作法

[attach]23240[/attach]
   

[attach]23238[/attach]

ThisWorkbook模組
  1. Option Explicit
  2. Private Sub Workbook_BeforeClose(Cancel As Boolean) '
  3.     '檔案關閉:關閉檔案連結
  4.     '**檔案在開啟時,不啟動詢問更新資料的視窗
  5.    
  6.     ActiveWorkbook.UpdateLinks = xlUpdateLinksNever
  7.     'UpdateLinks 屬性 傳回或設定 XlUpdateLink 常數，此常數可指出活頁簿更新內嵌 OLE 連線的設定。讀/寫。
  8.    
  9.     'XlUpdateLinks 可以是這些 XlUpdateLinks 常數之一。
  10.     'xlUpdateLinksAlways 永遠更新指定活頁簿的內嵌 OLE 連線。
  11.     'xlUpdateLinksNever 永遠不更新指定活頁簿的內嵌 OLE 連線。
  12.     'xlUpdateLinksUserSetting  根據使用者對指定活頁簿的設定來更新內嵌的 OLE 連線。
  13. End Sub

  15. Private Sub Workbook_Open()
  16.     Application.Calculation = xlAutomatic  ' 活頁簿設為自動重算
  17.     '檔案在開啟時:自動更新連結
  18.     With ActiveWorkbook
  19.         .UpdateRemoteReferences = True
  20.         .SaveLinkValues = True
  21.     End With
  22. End Sub
複製代碼
Sheet1(Sheets("RTD")) 模組的程式碼
  1. Option Explicit
  2. Dim D As Object, xTime As Date, Volume As Double
  3. Private Sub Worksheet_Calculate()
  4.     If IsError([E2]) Or Time < #8:45:00 AM# Then Application.StatusBar = "等候開盤中": Exit Sub
  5.    
  6.     '[E2] = "--" 開盤前的符號
  7.    If Volume <> [E2] And [E2] <> "--" And Time >= #8:45:00 AM# And Time < #1:46:00 PM# Then
  8.         If D Is Nothing Then
  9.             Application.OnTime #1:46:00 PM#, "SHEET1.紀錄"  '收盤後強制寫出最後一分鐘的資料
  10.             Application.StatusBar = False
  11.             Set D = CreateObject("scripting.dictionary")
  12.             Range("A" & Rows.Count).End(xlUp).CurrentRegion.Offset(1) = ""
  13.             Sheets("紀錄").UsedRange.Clear
  14.             xTime = TimeSerial(Hour(Time), Minute(Time), 0)
  15.         End If
  16.         If TimeSerial(Hour([B2]), Minute([B2]), 0) <> xTime And D.Count > 0 Then 紀錄 '下一分鐘開始時,紀錄上一分鐘的紀錄
  17.         D([C2].Value) = D([C2].Value) + IIf([D2] <= 10, -1, 1)    '字典物件:紀錄成交單量公式的值
  18.         Volume = [E2]
  19.         xTime = TimeSerial(Hour([B2]), Minute([B2]), 0)
  20.         '**************** 記錄每次成交紀錄***************
  21.          With Range("A" & Rows.Count).End(xlUp).Offset(1)
  22.             .Cells(1) = [B2]                        '時間
  23.             .Cells(1, 2) = [C2]                     '成交價
  24.             .Cells(1, 3) = [D2]                     '成交單數
  25.             .Cells(1, 4) = IIf([D2] <= 10, -1, 1)   '成交單量公式的值
  26.         End With
  27.         '************************************************
  28.     End If
  29. End Sub
  30. Private Sub 紀錄()
  31.     Dim R As Integer, C As Integer, X As Integer
  32.     Application.EnableEvents = False
  33.     With Sheets("紀錄")
  34.         If .[A1] = "" Then .[A1] = "時間"
  35.         With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
  36.             R = .Row
  37.             .NumberFormat = "HH:MM"
  38.             .Value = xTime
  39.             .Resize(2).Merge
  40.         End With
  41.         C = 2
  42.         '迴圈:字典物件的KEY(關鍵字) 最大值 - 最小值.
  43.         For X = Application.Max(D.KEYS) To Application.Min(D.KEYS) Step -1
  44.             If D.EXISTS(X) Then   '字典物件有這個KEY(關鍵字)
  45.                 If .Cells(1, C) = "" Then .Cells(1, C) = C - 1
  46.                 .Cells(R, C) = X
  47.                 .Cells(R, C).Interior.ColorIndex = 40
  48.             
  49.                 .Cells(R + 1, C) = D(X)
  50.                 C = C + 1
  51.             End If
  52.         Next
  53.     End With
  54.     D.RemoveAll   '重設,字典物件(紀錄成交價的公式的值)
  55.    
  56.    '這行的程式碼可刪除上一分鐘的資料,加速程式的運行
  57.     Range("A" & Rows.Count).End(xlUp).CurrentRegion.Offset(1) = ""    '如要保留可註解掉不必執行
  58.     Application.EnableEvents = True
  59. End Sub
複製代碼
作者: 藍天麗池    時間: 2016-2-3 16:24

回復 42# GBKEE


    G大今天台股封關了，要試也要等過年後了，謝謝妳
作者: jackyq    時間: 2016-2-3 17:20

回復 43# 藍天麗池


    封關一樣可試
作者: 藍天麗池    時間: 2016-2-23 17:37

回復 40# c_c_lai

http://forum.twbts.com/viewthread.php?tid=16452&extra=
C大新年快樂，有空可以麻煩幫我看看嗎??



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)