dreamsway

回復 19# GBKEE
不好意思 G大 又有問題想請教您了！
前幾天試著用檔案內的"sub執行"，採用"sub報價運算"搭配其他程序，在盤後運算非常快速沒問題，
盤中運算在開盤時數據較少，初期都可以正常運作，但後期就會變得一直運算，沒有顯示任何運算結果，直到excel崩潰或手動停止；
因為在盤後運行(數據不會更新)的情況下都可以非常順利運作，所以我試著改變報價及運算迴圈方式("sub執行"的方式)，讓每一個sub都跑完再進行重新整理來更新報價數據，卻也一樣一直運算而沒有結果(運作中沒有任何結果，但手動按下停止後運算結果就全部顯現...)，
設想是因為迴圈綁架了CPU之類的，觀察了CPU/記憶體使用率卻也不到50%，

為了試著將程式負擔再降低，想起之前您在本串14樓的時候有幫我寫過一個針對多空加總運算的sub (放在模組3的K心態)，當時沒有完整的多空判斷，現在想加入判斷式來歸類在多空上(請參考"sub報價運算")，
可能思考上一直碰壁，對Offset的方式一直無法整個理解，試著改來改去都失敗，
所以想詢問
1.此段程序該如何加上新增的判斷式呢
2.就您的經驗與在盤中執行遇到的問題，改成執行完後再進行報價更新，是否有幫助呢

因檔案超過附件容量限制，所以上傳至雲端Google雲端

謝謝！

GBKEE

回復 21# dreamsway
修改看看

1. ElseIf .Cells.Offset(1) = "" Then '****程式運行速度很快會跑完報價數據 **
   
2.                     wTime = Time   '**請在程式碼開端 Dim wTime As Date
   
3.                     Do
   
4.                         If wTime > Time - #12:00:30 AM# Then '30秒 重新整理 一次
   
5.                             Application.StatusBar = "重新整理...."
   
6.                             重新整理
   
7.                             wTime = Time
   
8.                         End If
   
9.                         DoEvents
   
10.                     Loop While .Cells.Offset(1) = ""  '**當 .Cells.Offset(1) = ""  一直執行下去
    
11.                     Application.StatusBar = False
    
12.                 End If

複製代碼

dreamsway

回復 22# GBKEE
G大午安，因為我還在試著學習更改新的多空判斷條件套用在這種相對路徑的寫法，所以這個時間延遲的部分可能需要明後天才能測試，
我想在原本的條件

1.   Do
   
2.         With Sheets("報價數據").Range("b2").Offset(i)
   
3.             If 成交價 < .Cells(1, 2) Then 多放 = 多放 + .Cells(1, 3) Else 多空 = 多空 + .Cells(1, 3)
   
4.             成交價 = .Cells(1, 2)

複製代碼

更改為

1. Do
   
2.         With Sheets("報價數據").Range("b1").Offset(i)
   
3.         If 成交價 < .Cells(1, 2) Then 方向 = "↑"
   
4.         If 成交價 > .Cells(1, 2) Then 方向 = "↓"
   
5.         If 成交價 <= .Cells(1, 2) And 方向 = "↑" Then 多總 = 多總 + .Cells(2, 3)
   
6.         If 成交價 >= .Cells(1, 2) And 方向 = "↓" Then 空總 = 空總 + .Cells(2, 3)
   
7.         成交價 = .Cells(1, 2)

複製代碼

想詢問為什麼這一行一直顯示錯誤

1. 成交價 = .Cells(1, 2)

複製代碼

[/code]
查了一下微軟說明顯示：嘗試指派值給 With...End With 陳述式中使用的結構成員，將會收到錯誤，但G大您提供的的代碼卻又正常:'( :'(

dreamsway

回復 22# GBKEE

雲端檔案
再麻煩G大解惑了，謝謝！

GBKEE

回復 24# dreamsway
Range.Offset 屬性  會傳回 Range 物件，代表從指定之範圍位移的範圍。
可再詳看說明

1. i = 0     '**b1 是標頭為文字   i=0  -->  .Offset(i) 還是b1,  成交價 As Double  ,所以有形態的錯誤
   
2. Do
   
3.         With Sheets("報價數據").Range("b1").Offset(i)
   
4.            
   
5.    

複製代碼

可修改

1. 
   
2.     i = 1
   
3.    Do
   
4.    With Sheets("報價數據").Range("b1").Offset(i)
   
5. 或是
   
6.     i = 0
   
7.    Do
   
8.    With Sheets("報價數據").Range("b2").Offset(i)
   

複製代碼

dreamsway

回復 22# GBKEE

G大您好！25樓的部分修改後已測試可以正確運算了，但21樓的問題仍在，
想詢問代碼的意思是每過30秒會執行迴圈嗎!? 因為單執行K心態sub，只會執行一次將現有的報價跑完，跳出MsgBox工作完成後就沒有任何動作，期間的重新整理也沒反應(執行前的報價跟執行結束的報價沒變，讓巨集運行整個停止也是沒變)
我試著用以下代碼的執行sub，讓他重新整理來獲取報價再執行K心態sub，則會讓K心態跑一次後一直呈現運轉狀態，但這期間報價不會更新、DDE數據也同步停止；直到我手動讓巨集停止運行後才會把這段期間的報價一次顯現出來

1. Sub 執行()
   
2. Call 共用參照
   
3. Sht1.Range("J1") = "運行中.."
   
4. uMode = 1
   
5. 
   
6. Do
   
7. Call 重新整理
   
8. Call K心態
   
9. 
   
10. Loop Until uMode = 0
    
11. 
    
12. If uMode = 0 Then
    
13. Sht1.Range("J1") = ">停止<"
    
14. End If
    
15. End Sub

複製代碼

附檔

GBKEE

回復 26# dreamsway

想詢問代碼的意思是每過30秒會執行迴圈嗎!? 因為單執行K心態sub，只會執行一次將現有的報價跑完，跳出後就沒有任何動作

是數據已跑到收盤時間了嗎?

請看一下註解的說明

1. Option Explicit
   
2. Const 間隔 = #12:05:00 AM#   '這裡修改分鐘間隔
   
3. Const 開盤 = #8:45:00 AM#
   
4. Sub K心態()
   
5.     Dim i As Long, Ti As Integer, 成交價 As Double, 多總 As Long, 空總 As Long, 方向 As String
   
6.     Dim xTime As Date, wTime As Date
   
7.     xTime = 開盤 + 間隔
   
8.     i = 1: Ti = 0: 多總 = 0: 空總 = 0
   
9.     成交價 = Sheets("多空藍圖").Range("M4") '欄位暫代
   
10.     Do
    
11.         With Sheets("報價數據").Range("b1").Offset(i)
    
12.         '**間隔為  #12:05:00 AM#  這"↑","↓"數據 準確嗎?***
    
13.         If 成交價 < .Cells(1, 2) Then 方向 = "↑"
    
14.         If 成交價 > .Cells(1, 2) Then 方向 = "↓"
    
15.         
    
16.         If 成交價 <= .Cells(1, 2) And 方向 = "↑" Then 多總 = 多總 + .Cells(2, 3)
    
17.         If 成交價 >= .Cells(1, 2) And 方向 = "↓" Then 空總 = 空總 + .Cells(2, 3)
    
18.         成交價 = .Cells(1, 2)
    
19.             If .Value > xTime + 間隔 Then
    
20.                 With Sheets("測試").Range("A2").Offset(Ti)
    
21.                     .Resize(, 3) = Array(xTime, 多總, 空總)
    
22.                     .NumberFormatLocal = "hh:mm;@"
    
23.                 End With
    
24.                  xTime = xTime + 間隔: Ti = Ti + 1
    
25.              Else
    
26.                 If .Cells.Offset(1) = "" And Format(TimeValue(.Cells.Text), "HH:MM") = "13:45" Then
    
27.                     '***程式運行速度很快會跑完報價數據,時間已到"13:45"收盤 不再有數據了 **
    
28.                     xTime = xTime + 間隔
    
29.                     With Sheets("測試").Range("A2").Offset(Ti)
    
30.                         .Resize(, 3) = Array(xTime, 多總, 空總)
    
31.                         .NumberFormatLocal = "hh:mm;@"
    
32.                     End With
    
33.                     Exit Do
    
34.                 ElseIf .Cells.Offset(1) = "" Then
    
35.                     '****程式運行速度很快會跑完報價數據,但是數據還會有 因時間還未到"13:45"收盤 時 ...  **
    
36.                     '**程式到這理 執行  重新整理 的程式 有更新到   _20180724_Match  對嗎? **
    
37.                      '**********************************************
    
38.                       Do
    
39.                         If wTime > Time - #12:00:30 AM# Then '30秒 重新整理 一次
    
40.                             '**試稍待一下等候新的數據
    
41.                             Application.StatusBar = "重新整理...."
    
42.                             重新整理   '** 更新   _20180724_Match 如有新的資料進來
    
43.                                        '*************************.Cells.Offset(1)就 <>""  ***
    
44.                             wTime = Time
    
45.                             End If
    
46.                         DoEvents
    
47.                     Loop While .Cells.Offset(1) = ""  '**還是沒有新的數據就一直等候...
    
48.                     '*** 如有新的資料進來 離開迴圈 繼續下去到  i = i + 1 的地方 再 Loop 下去 ***
    
49.                     Application.StatusBar = False
    
50.                 End If
    
51.             End If
    
52.         End With
    
53.         DoEvents
    
54.         i = i + 1
    
55.     Loop
    
56.     MsgBox "工作完成"
    
57. End Sub

複製代碼

dreamsway

回復 27# GBKEE
G大您好！ 今天在盤中測試發現狀況照舊，試著把報價手動作了調整後用一筆一筆F8監測，發現就算符合條件的情況下

1. If .Cells.Offset(1) = "" Then

複製代碼

但每次都會把wTime = Time以及重整的語法跳過去，所以之前都不會進行後面的重新整理
後來我把wTime = Time換了位置，變成以下代碼

1. Do
   
2.                       wTime = Time '語法位置調整
   
3.                         If wTime > Time - #12:00:30 AM# Then '30秒 重新整理 一次
   
4.                             '**試稍待一下等候新的數據
   
5.                             Application.StatusBar = "重新整理...."
   
6.                             重新整理   '** 更新   _20180724_Match 如有新的資料進來
   
7.                                        '*************************.Cells.Offset(1)就 <>""  ***
   
8.                             'wTime = Time 原本位置
   
9.                             End If
   
10.                         DoEvents

複製代碼

改完之後雖然會重新整理了....但每次回圈都重整，不會有30秒才重整的情況

1. if wTime > Time - #12:00:30 AM# Then '30秒 重新整理 一次

複製代碼

接著就是持續不間斷重新整理到EXCEL崩潰的情況發生
我在想是不是可以從重新整理那邊做調整

1. Sub 重新整理()
   
2. ActiveWorkbook.RefreshAll
   
3. End Sub

複製代碼

請問G大是否能改成像是5秒內再度執行會exit sub的語法呢
謝謝！

GBKEE

回復 28# dreamsway

程式碼有點錯誤請更正看看

1. ElseIf .Cells.Offset(1) = "" Then
   
2.                     '****程式運行速度很快會跑完報價數據,但是數據還會有 因時間還未到"13:45"收盤 時 ...  **
   
3.                     '**程式到這理 執行  重新整理 的程式 有更新到   _20180724_Match  對嗎? **
   
4.                      '**********************************************
   
5.                       wtime = Time   '** 抱歉這裡遺漏了*****
   
6.                       Do
   
7.                         '*** 還有應是 If wtime < Time - #12:00:30 AM# Then 才對
   
8.                         If wtime < Time - #12:00:30 AM# Then '30秒 重新整理 一次
   
9.                             '**試稍待一下等候新的數據
   
10.                             Application.StatusBar = "重新整理...."
    
11.                             重新整理   '** 更新   _20180724_Match 如有新的資料進來
    
12.                                        '*************************.Cells.Offset(1)就 <>""  ***
    
13.                             wtime = Time
    
14.                             End If
    
15.                         DoEvents
    
16.                     Loop While .Cells.Offset(1) = ""  '**還是沒有新的數據就一直等候...
    
17.                     '*** 如有新的資料進來 離開迴圈 繼續下去到  i = i + 1 的地方 再 Loop 下去 ***
    
18.                     Application.StatusBar = False
    
19.                 End If

複製代碼

dreamsway

回復 29# GBKEE
G大早安 測了幾天，若用手動F8測試已可以執行到重新整理及30秒的部分沒問題，
不過盤中在重整的地方一直卡關，手動重整是沒問題可以完整運行(約1秒就可以更新完)，但如果是透過巨集則會卡關，呈現一直轉圈但沒報價出現的情況，直到手動強制中斷巨集才會出現，
不知道是不是電腦太爛...不過CPU跟記憶體使用率都還頗低(最高只到35%左右)，這幾天找時間跟朋友借個好一點的電腦跑跑看，
另外在運算結果(多空數據)的呈現上，報價時間的最新兩個紀錄點不會記錄，例如報價已更新到16分，但15分跟20分的數據並不會顯現，
因為不會做GIF檔..所以用錄製的方式表現重整的狀況  影片