麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] API逐筆運算負擔大，可否精簡 [打印本頁]

作者: dreamsway 時間: 2018-10-13 02:39 標題: API逐筆運算負擔大，可否精簡

各位大大，小弟最近初學VBA，試著土法煉鋼把想要的方式改用VBA操作，巨集雖可以使用，但程式的負荷很重，是否有辦法精簡呢
採用的是API期貨報價，進行逐筆運算(範例的筆數很少，實際情況將隨時間變成幾萬筆資料)，並將B欄的成交時間複製到Sht1.Range("C1")
[attach]29524[/attach]
接著依照Sht1.Range("C1")的時間，將運算的結果(Sht2.Cells(4, "J")與Sht2.Cells(5, "J")) 貼在Sht3的B.C欄
每
[attach]29525[/attach]

Sub 多空紀錄()
Call 共用參照 '測試用
If Sht1.Range("C1") >= TimeValue("08:45:00") And Sht1.Range("C1") < TimeValue("08:50:00") Then
Sht3.Cells(2, "B") = Sht2.Cells(4, "J")
Sht3.Cells(2, "C") = Sht2.Cells(5, "J")
End If
If Sht1.Range("C1") >= TimeValue("08:50:00") And Sht1.Range("C1") < TimeValue("08:55:00") Then
Sht3.Cells(3, "B") = Sht2.Cells(4, "J")
Sht3.Cells(3, "C") = Sht2.Cells(5, "J")
End If
If Sht1.Range("C1") >= TimeValue("08:55:00") And Sht1.Range("C1") < TimeValue("09:00:00") Then
Sht3.Cells(4, "B") = Sht2.Cells(4, "J")
Sht3.Cells(4, "C") = Sht2.Cells(5, "J")
End If
If Sht1.Range("C1") >= TimeValue("09:00:00") And Sht1.Range("C1") < TimeValue("09:05:00") Then
Sht3.Cells(5, "B") = Sht2.Cells(4, "J")
Sht3.Cells(5, "C") = Sht2.Cells(5, "J")

複製代碼

如以上程式每5分鐘一個區間，一直記錄到13:45為止，
由於現在是每一筆成交就進行一次運算，1秒內可能成交很多筆交易，
有想過是否可以改為1秒進行一次紀錄就好，
再麻煩各位高手幫忙，謝謝！

作者: GBKEE 時間: 2018-10-13 08:55

本帖最後由 GBKEE 於 2018-10-13 09:01 編輯

回復 1# dreamsway
參考看看

Option Explicit
Public uMode&, StartTime, EndTime
Public MyBook As Workbook, Sht1 As Worksheet, Sht2 As Worksheet, Sht3 As Worksheet, xRow&
Sub 共用參照()
Set MyBook = ThisWorkbook
Set Sht1 = MyBook.Sheets("多空藍圖")
Set Sht2 = MyBook.Sheets("報價數據")
Set Sht3 = MyBook.Sheets("多空數據")
StartTime = "08:44:50" '開盤時間（提早十秒開始，才可記錄開盤量價）
End Sub
Sub 報價運算()
Dim xTime As Date
Call 共用參照 '測試用
If Sht2.Range("H2") <> 1 Then '開盤條件
Sht2.Range("J2,J4,J5").ClearContents '清除紀錄資料
Sht2.Range("K2") = Sht2.Range("I2") '判斷價改為開盤價
End If
i = 1
xTime = Time
Do
If Time > xTime Then 'Time 以秒計算的 ** Time > xTime = >下一秒 **
i = i + 1: xTime = Time
If Sht2.Cells(2, "J") = "↑" And Sht2.Cells(i, "H") <> 1 Then '多方加總
Sht2.Range("J4") = Sht2.Range("J4") + Sht2.Range("D" & i)
End If
If Sht2.Cells(2, "J") = "↓" And Sht2.Cells(i, "H") <> 1 Then '空方加總
Sht2.Range("J5") = Sht2.Range("J5") + Sht2.Range("D" & i)
End If
If Sht2.Cells(i, "H") <> 1 Then '報價時間傳送到多空藍圖
Sht1.Cells(1, "C") = Sht2.Range("B" & i)
End If
Call 多空紀錄
Sht2.Cells(i, "H") = 1 '運算過的進行標記避免重複運算
End If
Loop Until Sht2.Range("C" & i + 1) = 0 '迴圈停止條件
End Sub
Sub 多空紀錄()
Dim xMinute As Integer
Call 共用參照 '測試用
xMinute = Int(Application.Text(Time - #8:45:00 AM#, "[M]") / 5)
'*** xMinute 以 Time 距 8:45 的分鐘數 / 5 傳回的整數
'*** Time 小於 8:45 得到負數
If xMinute > -1 And Time <= #1:45:00 PM# Then
xMinute = xMinute + 2 '*** 從第2列開始
Sht3.Cells(xMinute, "B") = Sht2.Cells(4, "J")
Sht3.Cells(xMinute, "C") = Sht2.Cells(5, "J")
End If
End Sub
Sub 清除標記()
Call 共用參照 '測試用
Sht2.Columns("H").Clear
Sht2.Cells(1, "H").Value = "標記"
End Sub
Sub 清除報價()
Dim qyt As QueryTable '刪除外部連線
Call 共用參照 '測試用
With Sht2
.Columns("A:G").Clear '刪除後將標題名稱填入
.Columns("A:G").Rows(1) = Array("代號", "時間", "成交價", "單量", "總量", "最高價", "最高價", "最低價")
For Each qyt In .QueryTables
qyt.Delete
Next
End With
End Sub

複製代碼

作者: dreamsway 時間: 2018-10-13 11:45

回復 2# GBKEE
謝謝超版G大的協助
試運行了程式，發現會連報價運算的部分都變成1秒計算一次，
而多空紀錄似乎是以電腦時間來做紀錄，

因為小弟初學VBA，不確定是否有可能實現，
讓Sub 報價運算()的部分以正常速度運行，但Sub 多空紀錄()以程式的時間進行1秒1次(或是加條件新時間>舊時間)再判斷時間條件後記錄呢

作者: GBKEE 時間: 2018-10-13 12:47

回復 3# dreamsway
請自行試改看看
Sub 多空紀錄() 中 Time 改成 Sht1.Range("C1")

Sub 報價運算()
Dim xTime As Date
Call 共用參照 '測試用
If Sht2.Range("H2") <> 1 Then '開盤條件
Sht2.Range("J2,J4,J5").ClearContents '清除紀錄資料
Sht2.Range("K2") = Sht2.Range("I2") '判斷價改為開盤價
End If
i = 1
xTime = Time
Do
i = i + 1
If Sht2.Cells(2, "J") = "↑" And Sht2.Cells(i, "H") <> 1 Then '多方加總
Sht2.Range("J4") = Sht2.Range("J4") + Sht2.Range("D" & i)
End If
If Sht2.Cells(2, "J") = "↓" And Sht2.Cells(i, "H") <> 1 Then '空方加總
Sht2.Range("J5") = Sht2.Range("J5") + Sht2.Range("D" & i)
End If
If Sht2.Cells(i, "H") <> 1 Then '報價時間傳送到多空藍圖
Sht1.Cells(1, "C") = Sht2.Range("B" & i)
End If
If Time > xTime Then '** 一秒運行一次 **
xTime = Time
Call 多空紀錄
End If
Sht2.Cells(i, "H") = 1 '運算過的進行標記避免重複運算
Loop Until Sht2.Range("C" & i + 1) = 0 '迴圈停止條件
End Sub

複製代碼

作者: dreamsway 時間: 2018-10-13 19:12

回復 4# GBKEE
謝謝G大原本遇到一些問題，
研究了一下，紀錄的部分都解決了！
謝謝！

作者: dreamsway 時間: 2018-10-14 17:22

回復 4# GBKEE
不好意思，再另做一個紀錄15分K開高低收的巨集上遇到了困難(由於這跟原標題不完全符合，若需另主題再麻煩告知)
希望在原本逐筆計算的過程中，將每15分鐘的開高低收價格紀錄起來，運用o,h,l,c 四個變數
請問要如何在每15分鐘紀錄那邊，要換行紀錄時才將o,h,l變數歸0並重新計算呢

Option Explicit
Public uMode&, StartTime, EndTime
Public MyBook As Workbook, Sht1 As Worksheet, Sht2 As Worksheet, Sht3 As Worksheet, xRow&
Public o As Single, h As Single, l As Single c As Single
Sub 共用參照()
Set MyBook = ThisWorkbook
Set Sht1 = MyBook.Sheets("多空藍圖")
Set Sht2 = MyBook.Sheets("報價數據")
Set Sht3 = MyBook.Sheets("多空數據")
StartTime = "08:44:50" '開盤時間（提早十秒開始，才可記錄開盤量價）
End Sub
Sub 報價運算()
Dim xTime As Date
Dim i As Long
Call 共用參照 '測試用
If Sht2.Range("H2") <> 1 Then '開盤條件
Sht2.Range("J2,J4,J5").ClearContents '清除紀錄資料
Sht2.Range("K2") = Sht2.Range("I2") '判斷價改為開盤價
End If
i = 1
Do
i = i + 1
If Sht2.Cells(2, "J") = "↑" And Sht2.Cells(i, "H") <> 1 Then '多方加總
Sht2.Range("J4") = Sht2.Range("J4") + Sht2.Range("D" & i)
End If
If Sht2.Cells(2, "J") = "↓" And Sht2.Cells(i, "H") <> 1 Then '空方加總
Sht2.Range("J5") = Sht2.Range("J5") + Sht2.Range("D" & i)
End If
If Sht2.Cells(i, "H") <> 1 Then
Sht1.Cells(1, "C") = Sht2.Range("B" & i) '報價時間傳送到多空藍圖
End If
'***以下新增15分K紀錄
c = Sht2.Range("C" & i)
If c > h Then h = c '更新最高價
If c < l Then l = c '更新最低價
If o = 0 Then o = Sht2.Range("C" & i) Else o = o
If l = 0 Then l = Sht2.Range("C" & i) Else l = l
If h = 0 Then h = Sht2.Range("C" & i) Else h = h
Sht2.Range("O2").Value = o '填開盤價
Sht2.Range("P2").Value = h '填最高價
Sht2.Range("Q2").Value = l '填最低價
Sht2.Range("R2").Value = c '填收盤價
If Sht1.Range("C1") > xTime Then '** 一秒運行一次 **
Call 多空紀錄
Call 分K開高低收
End If
Sht2.Cells(i, "H") = 1 '運算過的進行標記避免重複運算
Loop Until Sht2.Range("C" & i + 1) = 0 '迴圈停止條件
End Sub
Sub 分K開高低收()
Call 共用參照 '測試用
Dim xMinute As Integer
xMinute = Int(Application.Text(Sht1.Range("C1") - #8:45:00 AM#, "[M]") / 15)
'*** xMinute 以 Time 距 8:45 的分鐘數 / 15 傳回的整數
'*** Time 小於 8:45 得到負數
If xMinute > -1 And Sht1.Range("C1") <= #1:45:00 PM# Then
xMinute = xMinute + 3 '*** 從第2列開始
Sht2.Cells(xMinute, "O") = Sht2.Cells(2, "O")
Sht2.Cells(xMinute, "P") = Sht2.Cells(2, "P")
Sht2.Cells(xMinute, "Q") = Sht2.Cells(2, "Q")
Sht2.Cells(xMinute, "R") = Sht2.Cells(2, "R")
End If
End Sub

複製代碼

作者: GBKEE 時間: 2018-10-15 15:34

回復 6# dreamsway

明天開盤可測看看

[attach]29535[/attach]

作者: dreamsway 時間: 2018-10-15 20:35

回復 7# GBKEE
謝謝超版G大，明天盤中測試看看，
雖然說這次的程式對我實在太深奧了，
還有好長的一條路，我會努力學習的！

作者: dreamsway 時間: 2018-10-16 10:36

回復 7# GBKEE
早安G大，因為這次的程式，小弟慢慢查MSDN一些程式的含意仍然不甚了解，我大概描述一下使用上的問題，再請您多多指導，
一開始照著說明存檔後重開(您提供的原檔)，沒有任何反應，也覺得很奇怪這樣沒報價的數據怎麼運算呢，
接著觀察到以下代碼，

Set Rng = Sheets("多空藍圖").Range("A2") '** 指數代號

複製代碼

並將Sheets("多空藍圖").Range("A2")填上代碼後存檔重開，即新創了一個試算表，試算表名稱為指數的代號，
其試算表也跑出

Names.Add "Ar", Array("1分", "5分", "10分", "15分", "20分", "30分", "60分")

複製代碼

等各項欄位名稱，但因為沒有報價數據，所以並沒有在運算，
接下來我把程式貼到我原本的檔案，並將

Set Rng = Sheets("多空藍圖").Range("A2") '** 指數代號

複製代碼

改成我原本的報價區域

Set Rng = Sheets("報價數據").Range("A2") '** 指數代號

複製代碼

重啟後EXCEL呈現負載沒回應的狀態，嘗試等了5分鐘以上，其新的試算表(1-60分K紀錄)仍然為空白，接著就EXCEL無回應崩潰了，
之後在檔案重啟後關閉巨集運行，進行數次偵錯
都顯示在以下程式碼

.Offset(1).Resize(, 3) = Array("時間", "多方加總", "空方加總")

複製代碼

不知是小弟哪邊操作上有誤嗎!?

作者: GBKEE 時間: 2018-10-16 10:50

本帖最後由 GBKEE 於 2018-10-16 10:53 編輯

回復 9# dreamsway

由於現在是每一筆成交就進行一次運算，1秒內可能成交很多筆交易

這資料是哪裡來的

多空藍圖上是需填上Dee公式的如你沒有
請附上你的原始檔案看看

作者: dreamsway 時間: 2018-10-16 15:48

回復 10# GBKEE
G大午安
報價數據是透過期貨商API的將報價傳輸到電腦成為txt檔(這樣較能避免傳統DDE/RTD漏tick的情況發生)，再透過EXCEL去取得txt資料(附件裡面20180724_Match 這個txt檔)，我有設了巨集但路徑應該需要更改
由於是隨時間增加報價內容，而EXCEL似乎不會自動更新(我看內建最短要1分鐘)，所以將會設一個短時間延遲的報價連線的重新整理(視程式負擔)
附件為原始檔，原本有RTD的部分，需要外掛一堆期貨商的程式，所以先把那些欄位資料清掉了，因為那些資料只是呈現而已，巨集不會運用到，
再麻煩G大了，謝謝！

作者: GBKEE 時間: 2018-10-16 16:32

本帖最後由 GBKEE 於 2018-10-16 18:13 編輯

回復 11# dreamsway

"透過期貨商API的將報價傳輸到電腦成為txt檔"
是股市營業時間一直在接收然後"成為txt檔" ?

"原本有RTD的部分，需要外掛一堆期貨商的程式"
給你的檔案就是輸入這些的公式,於股市營業時間接收資料
我是用台新證券的智多星看盤接收資料

[attach]29539[/attach]

這裡要修改
ThisWorkbook.Sheets("多空藍圖").Range("A2") '** 指數代號

Sub AUTO_OPEN()
Dim i As Integer, A, Rng As Range, xName As String, n As Name
'*** 設定分鐘的間隔***
Names.Add "Ar", Array("1分", "5分", "10分", "15分", "20分", "30分", "60分")
Set Rng = ThisWorkbook.Sheets("多空藍圖").Range("A2") '** 指數代號
On Error GoTo Sh_Add '處理程式錯誤時的措施

複製代碼

這裡要修改
Dim 成交價 As Double, 多空 As Long, 多放 As Long
With ThisWorkbook.Sheets(Rng(1).Value) '**工作表(指數代號)

Private Sub Worksheet_Calculate()
Dim Rng(1 To 2) As Range, i As Integer, xName As String, xTime(1 To 2) As Date, T(1 To 2) As Integer
Dim 成交價 As Double, 多空 As Long, 多放 As Long
If IsError([sum(a:e)]) Then Exit Sub '**開盤前的清盤DEE有時會傳回空值 #NA
Set Rng(1) = [a2] '**第一個指數代號
xTime(1) = #8:45:00 AM# '**開盤時間
Do While Rng(1) <> "" '**執行迴圈的條件是指數代號<>""
With ThisWorkbook.Sheets(Rng(1).Value) '**工作表(指數代號)

複製代碼

作者: dreamsway 時間: 2018-10-16 21:37

回復 12# GBKEE

是股市營業時間一直在接收然後"成為txt檔" ?

是的，我用元大的SMART API ，開盤前先設定好商品名，就會在指定點建立一個無資料的txt，當開盤後開始有資料就會一直覆蓋，
我用過元大、永豐、XQ的DDE/RTD
但期貨交易太快，漏tick嚴重，快市交易之前測過，整天成交量漏了3成以上
所以才選用txt這種比較麻煩的方法，但是數據幾乎不會漏

作者: GBKEE 時間: 2018-10-17 09:24

回復 13# dreamsway

但期貨交易太快，漏tick嚴重，快市交易之前測過，整天成交量漏了3成以上
所以才選用txt這種比較麻煩的方法，但是數據幾乎不會漏

檔案上另加一模組複製這程式試試看

Option Explicit
Const 間隔 = #12:15:00 AM# '這裡修改分鐘間隔
Const 開盤 = #8:45:00 AM#
Sub k_15()
Dim i As Long, Ti As Integer, 成交價 As Double, 多空 As Long, 多放 As Long
Dim xTime As Date
xTime = 開盤 + 間隔
i = 0: Ti = 0
Do
With Sheets("報價數據").Range("b2").Offset(i)
If 成交價 < .Cells(1, 2) Then 多放 = 多放 + .Cells(1, 3) Else 多空 = 多空 + .Cells(1, 3)
成交價 = .Cells(1, 2)
If .Value > xTime + 間隔 Then
With Sheets("多空數據").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多放, 多空)
.NumberFormatLocal = "hh:mm;@"
End With
xTime = xTime + 間隔: Ti = Ti + 1
Else
If .Cells.Offset(1) = "" And Format(TimeValue(.Cells.Text), "HH:MM") = "13:45" Then
xTime = xTime + 間隔
With Sheets("多空數據").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多放, 多空)
.NumberFormatLocal = "hh:mm;@"
End With
Exit Do
ElseIf .Cells.Offset(1) = "" Then '****程式運行速度很快會跑完報價數據 **
Do
DoEvents
'***程式等候... 報價文字檔的資料傳入**
Loop Until Time >= xTime + #12:00:30 AM#
匯入API報價文字檔
End If
End If
End With
DoEvents
i = i + 1
Loop
MsgBox "工作完成"
End Sub

複製代碼

作者: dreamsway 時間: 2018-10-18 09:58

回復 14# GBKEE
G大早安，經過兩天的測試，發現可以運行，但都會在當下時間的前一筆紀錄的區域發生錯誤，例如現在時間9:36 就會只記錄到09:30後需要偵錯

If .Cells.Offset(1) = "" And Format(TimeValue(.Cells.Text), "HH:MM") = "13:45" Then

複製代碼

標記這行代碼，但我也看不出是哪邊有問題，不過若以盤後執行的話速度確實飛快呀!!(盤後可以完整運行無偵錯)
以下是我調整過的

Option Explicit
Const 間隔 = #12:05:00 AM# '這裡修改分鐘間隔
Const 開盤 = #8:45:00 AM#
Sub k_15()
Dim i As Long, Ti As Integer, 成交價 As Double, 多空 As Long, 多放 As Long
Dim xTime As Date
xTime = 開盤 + 間隔
i = 0: Ti = 0
Do
With Sheets("報價數據").Range("b2").Offset(i)
If 成交價 < .Cells(1, 2) Then 多放 = 多放 + .Cells(1, 3) Else 多空 = 多空 + .Cells(1, 3)
成交價 = .Cells(1, 2)
If .Value > xTime + 間隔 Then
With Sheets("多空數據").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多放, 多空)
.NumberFormatLocal = "hh:mm;@"
End With
xTime = xTime + 間隔: Ti = Ti + 1
Else
If .Cells.Offset(1) = "" And Format(TimeValue(.Cells.Text), "HH:MM") = "13:45" Then
xTime = xTime + 間隔
With Sheets("多空數據").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多放, 多空)
.NumberFormatLocal = "hh:mm;@"
End With
Exit Do
ElseIf .Cells.Offset(1) = "" Then '****程式運行速度很快會跑完報價數據 **
Do
DoEvents
'***程式等候... 報價文字檔的資料傳入**
Loop Until Time >= xTime + #12:00:20 AM#
重新整理
End If
End If
End With
DoEvents
i = i + 1
Loop
MsgBox "工作完成"
End Sub

複製代碼

Sub 重新整理()
ActiveWorkbook.RefreshAll
End Sub

複製代碼

報價數據的更新採用重新整理，其價格就會更新了，
另外，我看G大把巨集名稱設為K15，然後看執行的結果似乎是以15分鐘去紀錄多方加總與空方加總，
小弟愚笨，想詢問該如何調整為6樓的那項開高低收價格呢，謝謝！

作者: GBKEE 時間: 2018-10-18 17:23

本帖最後由 GBKEE 於 2018-10-18 17:25 編輯

回復 15# dreamsway
再試試看

Option Explicit
Const K = #12:15:00 AM# '這裡修改
Const 開盤 = #8:45:00 AM#
Sub k_15()
Dim i As Long, Ti(1 To 3) As Integer, 成交價 As Double
Dim xTime As Date, AR(1 To 6)
AR(1) = "時間": AR(2) = "開盤": AR(3) = "最高": AR(4) = "最低": AR(5) = "收盤": AR(6) = "成交量"
With Sheets("多空數據")
.UsedRange.Clear '清盤
.[A1].Resize(, UBound(AR)) = AR '給標頭
End With
xTime = 開盤 + IIf(K = #12:01:00 AM#, 0, K) '開盤+ K 的分鐘數
Ti(2) = Application.Text(xTime, "[m]")
Ti(3) = 0 'K數次
i = 0
AR(1) = xTime: AR(2) = 0: AR(3) = 0: AR(4) = 0: AR(5) = 0: AR(6) = 0
Do
With Sheets("報價數據").Range("b2").Offset(i)
成交價 = .Range("B1")
Ti(1) = Application.Text(.Cells.Offset(1), "[m]") '下一個報價時間的分鐘數
AR(2) = IIf(AR(2) = 0, 成交價, AR(2)) '開盤
AR(3) = IIf(成交價 >= AR(3), 成交價, AR(3)) '最高
AR(4) = IIf(AR(4) = 0, 成交價, IIf(成交價 <= AR(4), 成交價, AR(4))) '最低
AR(6) = AR(6) + .Range("C1") '成交量
If Ti(1) > Ti(2) Then
AR(5) = 成交價 '收盤"
With Sheets("多空數據").Range("A2").Offset(Ti(3))
.Resize(, UBound(AR)) = AR
.NumberFormatLocal = "hh:mm;@"
End With
xTime = xTime + K '下一個K時間點
Ti(2) = Application.Text(xTime, "[m]") '重新計算K時間點的分鐘數
Ti(3) = Ti(3) + 1 'K數次+1
AR(1) = xTime: AR(2) = 0: AR(3) = 0: AR(4) = 0: AR(5) = 0: AR(6) = 0 ''陣列重新給值
Else
If .Cells.Offset(1) = "" And CDate(.Cells.Value) = CDate(#1:45:00 PM#) Then
AR(5) = .Cells.Offset(0, 1) '收盤"
With Sheets("多空數據").Range("A2").Offset(Ti(3))
.Resize(, UBound(AR)) = AR
.NumberFormatLocal = "hh:mm;@"
End With
Exit Do
ElseIf .Cells.Offset(1) = "" Then
匯入API報價文字檔
End If
End If
End With
DoEvents
i = i + 1
Loop
End Sub

複製代碼

作者: dreamsway 時間: 2018-10-20 16:42

回復 16# GBKEE

謝謝G大，昨天不知是不是沒有開盤前執行，有一些小問題需要研究一番，等週一再來完整的測測看

作者: dreamsway 時間: 2018-10-21 15:43

回復 16# GBKEE
G大您好！原本之前以為是沒在開盤前執行，所以數據抓得不準確，
後來自己手動把原始的報價數據做過調整方便對照，
發現原本應該只到09:00:00的數據會記錄到09:00:59；09:15:00的數據則會記錄到09:15:59 (會往後推59秒.以此類推)
設想應該可以從程式判定分鐘的部分做調整，又或者把開盤時間設定往前移，(開盤設08:44:59，則會只紀錄到08:59:59)
但我試著更改了幾個部分皆無效，想詢問是否有改善方法呢，謝謝！

作者: GBKEE 時間: 2018-10-22 07:43

回復 18# dreamsway
試試看

Option Explicit
Const K = #12:15:00 AM#
Const 開盤 = #8:45:00 AM#
Sub k_15()
Dim i As Long, Ti(1 To 3) As Long, 成交價 As Double
Dim xTime As Date, AR(1 To 6)
AR(1) = "時間": AR(2) = "開盤": AR(3) = "最高": AR(4) = "最低": AR(5) = "收盤": AR(6) = "成交量"
With Sheets("多空數據")
.UsedRange.Clear '清盤
.[A1].Resize(, UBound(AR)) = AR '給標頭
End With
xTime = 開盤 + IIf(K = #12:01:00 AM#, 0, K) '第一個K時間點
Ti(1) = Application.Text(xTime, "[S]") 'K時間點的秒數
Ti(3) = 0 'K數次
i = 0 '指定報價的列號 '
AR(1) = Format(xTime, "hh:mm"): AR(2) = 0: AR(3) = 0: AR(4) = 0: AR(5) = 0: AR(6) = 0 '陣列重新給值
Do
With Sheets("報價數據").Range("b2").Offset(i)
成交價 = .Range("B1")
Ti(2) = Application.Text(.Cells.Offset(1), "[S]") '.Cells.Offset(1) -> 下一個報價時間秒數
AR(2) = IIf(AR(2) = 0, 成交價, AR(2)) '開盤
AR(3) = IIf(成交價 >= AR(3), 成交價, AR(3)) '最高
AR(4) = IIf(AR(4) = 0, 成交價, IIf(成交價 <= AR(4), 成交價, AR(4))) '最低
AR(5) = 成交價 '收盤
AR(6) = AR(6) + .Range("C1") '成交量
If Ti(2) > Ti(1) Then '下一個報價時間秒數 > K點時間的秒數
Sheets("多空數據").Range("A2").Offset(Ti(3)).Resize(, UBound(AR)) = AR 'k時間點導入陣列
xTime = xTime + K '下一個K時間點
Ti(1) = Application.Text(xTime, "[S]") '下一個 K 點時間的秒數
Ti(3) = Ti(3) + 1 'K數次+1
AR(1) = Format(xTime, "hh:mm"): AR(2) = 0: AR(3) = 0: AR(4) = 0: AR(5) = 0: AR(6) = 0 '陣列重新給值
Else
If .Cells.Offset(1) = "" And CDate(.Cells.Value) = CDate(#1:45:00 PM#) Then
'下一個報價時間="" 且報價時間=收盤時間
Sheets("多空數據").Range("A2").Offset(Ti(3)).Resize(, UBound(AR)) = AR 'k時間點導入陣列
Exit Do '離開迴圈
ElseIf .Cells.Offset(1) = "" Then '這條件不成立 (下一個報價時間="" 且報價時間=收盤時間 )
匯入API報價文字檔
End If
End If
End With
DoEvents '暫停執行，以便讓作業系統可以處理其它的事件
i = i + 1 '報價的列號 +1
Loop
End Sub

複製代碼

作者: dreamsway 時間: 2018-10-25 12:07

回復 19# GBKEE
謝謝超版G大，之前在盤後使用完全正常，一到盤中實測就冒出問題
測試了好幾天，終於調整好了，謝謝！

作者: dreamsway 時間: 2018-10-29 18:43

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

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

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

謝謝！

作者: GBKEE 時間: 2018-10-30 06:57

回復 21# dreamsway
修改看看

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

複製代碼

作者: dreamsway 時間: 2018-10-30 14:47

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

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

複製代碼

更改為

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

複製代碼

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

成交價 = .Cells(1, 2)

複製代碼

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

作者: dreamsway 時間: 2018-10-30 19:00

回復 22# GBKEE

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

作者: GBKEE 時間: 2018-10-30 19:42

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

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

複製代碼

可修改

i = 1
Do
With Sheets("報價數據").Range("b1").Offset(i)
或是
i = 0
Do
With Sheets("報價數據").Range("b2").Offset(i)

複製代碼

作者: dreamsway 時間: 2018-10-31 20:42

回復 22# GBKEE

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

Sub 執行()
Call 共用參照
Sht1.Range("J1") = "運行中.."
uMode = 1
Do
Call 重新整理
Call K心態
Loop Until uMode = 0
If uMode = 0 Then
Sht1.Range("J1") = ">停止<"
End If
End Sub

複製代碼

附檔

作者: GBKEE 時間: 2018-11-1 15:51

回復 26# dreamsway

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

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

請看一下註解的說明

Option Explicit
Const 間隔 = #12:05:00 AM# '這裡修改分鐘間隔
Const 開盤 = #8:45:00 AM#
Sub K心態()
Dim i As Long, Ti As Integer, 成交價 As Double, 多總 As Long, 空總 As Long, 方向 As String
Dim xTime As Date, wTime As Date
xTime = 開盤 + 間隔
i = 1: Ti = 0: 多總 = 0: 空總 = 0
成交價 = Sheets("多空藍圖").Range("M4") '欄位暫代
Do
With Sheets("報價數據").Range("b1").Offset(i)
'**間隔為 #12:05:00 AM# 這"↑","↓"數據準確嗎?***
If 成交價 < .Cells(1, 2) Then 方向 = "↑"
If 成交價 > .Cells(1, 2) Then 方向 = "↓"
If 成交價 <= .Cells(1, 2) And 方向 = "↑" Then 多總 = 多總 + .Cells(2, 3)
If 成交價 >= .Cells(1, 2) And 方向 = "↓" Then 空總 = 空總 + .Cells(2, 3)
成交價 = .Cells(1, 2)
If .Value > xTime + 間隔 Then
With Sheets("測試").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多總, 空總)
.NumberFormatLocal = "hh:mm;@"
End With
xTime = xTime + 間隔: Ti = Ti + 1
Else
If .Cells.Offset(1) = "" And Format(TimeValue(.Cells.Text), "HH:MM") = "13:45" Then
'***程式運行速度很快會跑完報價數據,時間已到"13:45"收盤不再有數據了 **
xTime = xTime + 間隔
With Sheets("測試").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多總, 空總)
.NumberFormatLocal = "hh:mm;@"
End With
Exit Do
ElseIf .Cells.Offset(1) = "" Then
'****程式運行速度很快會跑完報價數據,但是數據還會有因時間還未到"13:45"收盤時 ... **
'**程式到這理執行重新整理的程式有更新到 _20180724_Match 對嗎? **
'**********************************************
Do
If wTime > Time - #12:00:30 AM# Then '30秒重新整理一次
'**試稍待一下等候新的數據
Application.StatusBar = "重新整理...."
重新整理 '** 更新 _20180724_Match 如有新的資料進來
'*************************.Cells.Offset(1)就 <>"" ***
wTime = Time
End If
DoEvents
Loop While .Cells.Offset(1) = "" '**還是沒有新的數據就一直等候...
'*** 如有新的資料進來離開迴圈繼續下去到 i = i + 1 的地方再 Loop 下去 ***
Application.StatusBar = False
End If
End If
End With
DoEvents
i = i + 1
Loop
MsgBox "工作完成"
End Sub

複製代碼

作者: dreamsway 時間: 2018-11-2 22:05

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

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

複製代碼

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

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

複製代碼

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

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

複製代碼

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

Sub 重新整理()
ActiveWorkbook.RefreshAll
End Sub

複製代碼

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

作者: GBKEE 時間: 2018-11-3 14:40

回復 28# dreamsway

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

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

複製代碼

作者: dreamsway 時間: 2018-11-6 11:48

本帖最後由 dreamsway 於 2018-11-6 11:49 編輯

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

作者: GBKEE 時間: 2018-11-6 15:48

本帖最後由 GBKEE 於 2018-11-6 15:50 編輯

回復 30# dreamsway

11# 上的多空藍圖beta不含RTD.xls 中 Sub 匯入API報價文字檔() '** 不就是在更新 _20180724_Match 的資料
替代重新整理看看

作者: dreamsway 時間: 2018-11-6 17:04

回復 31# GBKEE
因為現在改用2019版EXCEL(元大的RTD才能使用在win10及API才能使用數據超過65536筆)，
所以匯入外部txt的方式變得比較不同，若用巨集重複執行匯入txt就會出現以下訊息
[attach]29651[/attach]
因此才改用重新整理的方式

作者: GBKEE 時間: 2018-11-6 18:59

回復 32# dreamsway

試試看

Option Explicit
Const 間隔 = #12:05:00 AM# '這裡修改分鐘間隔
Const 開盤 = #8:45:00 AM#
Public Sht2 As Worksheet
Sub K心態()
Dim i As Long, Ti As Integer, 成交價 As Double, 多總 As Long, 空總 As Long, 方向 As String
Dim xTime As Date, wTime As Date, Q As Variant
'*************************************
Set Sht2 = Sheets("報價數據")
With Sht2
For Each Q In .QueryTables
Q.Delete
Next
For Each Q In .Names
Q.Delete
Next
End With
匯入API報價文字檔
'**************************************
xTime = 開盤 + 間隔
i = 1: Ti = 0: 多總 = 0: 空總 = 0
成交價 = Sheets("多空藍圖").Range("M4") '欄位暫代
Do
With Sht2.Range("b1").Offset(i)
'**間隔為 #12:05:00 AM# 這"↑","↓"數據準確嗎?***
If 成交價 < .Cells(1, 2) Then 方向 = "↑"
If 成交價 > .Cells(1, 2) Then 方向 = "↓"
If 成交價 <= .Cells(1, 2) And 方向 = "↑" Then 多總 = 多總 + .Cells(2, 3)
If 成交價 >= .Cells(1, 2) And 方向 = "↓" Then 空總 = 空總 + .Cells(2, 3)
成交價 = .Cells(1, 2)
If .Value > xTime + 間隔 Then
With Sheets("測試").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多總, 空總)
.NumberFormatLocal = "hh:mm;@"
End With
xTime = xTime + 間隔: Ti = Ti + 1
Else
If .Cells.Offset(1) = "" And Format(TimeValue(.Cells.Text), "HH:MM") = "13:45" Then
'***程式運行速度很快會跑完報價數據,時間已到"13:45"收盤不再有數據了 **
xTime = xTime + 間隔
With Sheets("測試").Range("A2").Offset(Ti)
.Resize(, 3) = Array(xTime, 多總, 空總)
.NumberFormatLocal = "hh:mm;@"
End With
Exit Do
ElseIf .Cells.Offset(1) = "" Then
'****程式運行速度很快會跑完報價數據,但是數據還會有因時間還未到"13:45"收盤時 ... **
'**程式到這理執行重新整理的程式有更新到 _20180724_Match 對嗎? **
'**********************************************
wTime = Time
Do
If wTime < Time - #12:00:30 AM# Then '30秒重新整理一次
'**試稍待一下等候新的數據
Application.StatusBar = "重新整理...."
匯入API報價文字檔 '** 更新 _20180724_Match 如有新的資料進來
'*************************.Cells.Offset(1)就 <>"" ***
wTime = Time
End If
DoEvents
Loop While .Cells.Offset(1) = "" '**還是沒有新的數據就一直等候...
'*** 如有新的資料進來離開迴圈繼續下去到 i = i + 1 的地方再 Loop 下去 ***
Application.StatusBar = False
End If
End If
End With
DoEvents
i = i + 1
Loop
MsgBox "工作完成"
End Sub
Sub 匯入API報價文字檔() '還沒調整路徑字串，路徑2組日期改為當日日期，TXFH8則為sht1多空藍圖的A4儲存格
With Sht2
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:= _
"TEXT;C:\API\20180724\TXFH8\20180724_Match.txt", Destination:=.Range("$A$2"))
.Name = "20180724_Match"
'.FieldNames = True '預設值為 True 可不用列出
.RowNumbers = False
.FillAdjacentFormulas = False
'.PreserveFormatting = True '預設值為 True。可不用列出
'.RefreshOnFileOpen = False '預設值為 False。可不用列出
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
'.AdjustColumnWidth = True '預設值為 True。可不用列出
.RefreshPeriod = 0
'.TextFilePromptOnRefresh = False '預設值為 False。可不用列出
.TextFilePlatform = 950
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
'.TextFileConsecutiveDelimiter = False '預設值為 False 。可不用列出
.TextFileTabDelimiter = True
'.TextFileSemicolonDelimiter = False '預設值為 False 。可不用列出
.TextFileCommaDelimiter = True
'.TextFileSpaceDelimiter = False '預設值為 False 。可不用列出
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Else
.QueryTables(1).Refresh
End If
.Columns("B:B").NumberFormatLocal = "h:mm:ss;@"
End With
End Sub

複製代碼

作者: dreamsway 時間: 2018-11-7 17:43

回復 33# GBKEE
謝謝G大，今天盤中實測的情況可以一直更新報價的數據了，不過會變成多空數據的部分跑不出來(8:50前測試情況)，
若在8:50後才執行巨集，則會持續更新報價，然後多空數據會跑一次初次的報價(只會記錄一次)，接著就是持續更新報價，但後續更新的報價運算的多空數據皆不會顯現。
但詭異的是...我試著手動F8測試，用監看每個變數卻又完全正常，可以跑報價也能跑多總空總的判斷，
小弟對VBA了解不多，不禁在想...會不會這兩種巨集自動運行時會衝突呀...一下是報價不會更新...這回是運算不會動...但手動F8卻又正常
不曉得是否這樣的運算對EXCEL.VBA來說負荷過重，一直請G大協助的情況感覺很過意不去...

作者: GBKEE 時間: 2018-11-8 13:18

回復 34# dreamsway

'**間隔為 #12:05:00 AM# 這"↑","↓"數據準確嗎?***

我不是有這疑問嗎?

作者: dreamsway 時間: 2018-11-9 16:10

本帖最後由 dreamsway 於 2018-11-9 16:12 編輯

回復 35# GBKEE
G大午安，那個↑↓指標的判斷是正確的，
我目前測到用這樣自動更新的方式，採用較之前您幫我修改的報價運算sub搭配多空紀錄sub，放在自動更新的sub內，報價及運算已測試兩天皆可順利運行，就是...盤中交易量大一點的瞬間會稍微頓一下(可能電腦該換了...)
雖然有點納悶為什麼自動更新可以，之前的重新整理就不行...

Sub 執行()
Call 共用參照
Sht1.Range("J1") = "運行中.."
uMode = "Start"
Call 自動更新
If uMode = "Stop" Then
Sht1.Range("J1") = ">停止<"
Exit Sub
End If
End Sub

複製代碼

Sub 自動更新()
On Error Resume Next
ActiveWorkbook.RefreshAll
If uMode = "Stop" Then Exit Sub
Application.OnTime Now + TimeValue("00:00:15"), "自動更新"
Call 報價運算 '裡面會再call 多空紀錄
Call 高低更新
Call K15
Call 動態價
End Sub

複製代碼

但若是我把自動更新sub裡面的call 報價運算改為K心態sub
若跑一輪沒在自動更新設定的15秒內跑完，就會開始之前的情況，導致報價一直更新但K心態也跑不完的狀況
另外，因為其他的sub都需要報價時間來做判斷，我試著在K心態內加上報價時間傳送到sht1.Range("C1") ，結果速度變得奇慢無比..
請問是不是這種寫法不適用這種逐筆更新另一個儲存格內容的狀況呢，因為目前的K心態是K棒時間收定後看到上一根運算的結果(例如現在09:49但只會看到09:45運算的結果)
不曉得能否看到即時的運算(例如報價時間09:49就看到運算到09:49的數據，而不用等到09:50過後)
如果不行的話就先採用目前已能順利運行的方式去跑，因為G大您幫我改過的多空紀錄，已經比我最原始的紀錄方式運行速度快非常多了

檔案

作者: GBKEE 時間: 2018-11-9 18:13

回復 36# dreamsway

未能實際參與你的檔案,很難幫你修改.
期貨我是門外漢,我有台新證券,智多星軟體,但找不到你 TXFH8 指數

作者: dreamsway 時間: 2018-11-9 18:56

回復 37# GBKEE
謝謝G大這陣子的協助，我先用目前的版本就可以了，
這個代碼似乎只限於元大的EASYWIN軟體用的，但是元大的DDE/RTD/API都是綁這個。

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