- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
42#
發表於 2016-2-3 09:49
| 只看該作者
本帖最後由 GBKEE 於 2016-2-3 10:34 編輯
回復 38# 藍天麗池
附檔試試看看另一作法
 EX.rar (28.72 KB)
ThisWorkbook模組- Option Explicit
- Private Sub Workbook_BeforeClose(Cancel As Boolean) '
- '檔案關閉:關閉檔案連結
- '**檔案在開啟時,不啟動詢問更新資料的視窗
-
- ActiveWorkbook.UpdateLinks = xlUpdateLinksNever
- 'UpdateLinks 屬性 傳回或設定 XlUpdateLink 常數，此常數可指出活頁簿更新內嵌 OLE 連線的設定。讀/寫。
-
- 'XlUpdateLinks 可以是這些 XlUpdateLinks 常數之一。
- 'xlUpdateLinksAlways 永遠更新指定活頁簿的內嵌 OLE 連線。
- 'xlUpdateLinksNever 永遠不更新指定活頁簿的內嵌 OLE 連線。
- 'xlUpdateLinksUserSetting 根據使用者對指定活頁簿的設定來更新內嵌的 OLE 連線。
- End Sub
- Private Sub Workbook_Open()
- Application.Calculation = xlAutomatic ' 活頁簿設為自動重算
- '檔案在開啟時:自動更新連結
- With ActiveWorkbook
- .UpdateRemoteReferences = True
- .SaveLinkValues = True
- End With
- End Sub
- Option Explicit
- Dim D As Object, xTime As Date, Volume As Double
- Private Sub Worksheet_Calculate()
- If IsError([E2]) Or Time < #8:45:00 AM# Then Application.StatusBar = "等候開盤中": Exit Sub
-
- '[E2] = "--" 開盤前的符號
- If Volume <> [E2] And [E2] <> "--" And Time >= #8:45:00 AM# And Time < #1:46:00 PM# Then
- If D Is Nothing Then
- Application.OnTime #1:46:00 PM#, "SHEET1.紀錄" '收盤後強制寫出最後一分鐘的資料
- Application.StatusBar = False
- Set D = CreateObject("scripting.dictionary")
- Range("A" & Rows.Count).End(xlUp).CurrentRegion.Offset(1) = ""
- Sheets("紀錄").UsedRange.Clear
- xTime = TimeSerial(Hour(Time), Minute(Time), 0)
- End If
- If TimeSerial(Hour([B2]), Minute([B2]), 0) <> xTime And D.Count > 0 Then 紀錄 '下一分鐘開始時,紀錄上一分鐘的紀錄
- D([C2].Value) = D([C2].Value) + IIf([D2] <= 10, -1, 1) '字典物件:紀錄成交單量公式的值
- Volume = [E2]
- xTime = TimeSerial(Hour([B2]), Minute([B2]), 0)
- '**************** 記錄每次成交紀錄***************
- With Range("A" & Rows.Count).End(xlUp).Offset(1)
- .Cells(1) = [B2] '時間
- .Cells(1, 2) = [C2] '成交價
- .Cells(1, 3) = [D2] '成交單數
- .Cells(1, 4) = IIf([D2] <= 10, -1, 1) '成交單量公式的值
- End With
- '************************************************
- End If
- End Sub
- Private Sub 紀錄()
- Dim R As Integer, C As Integer, X As Integer
- Application.EnableEvents = False
- With Sheets("紀錄")
- If .[A1] = "" Then .[A1] = "時間"
- With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
- R = .Row
- .NumberFormat = "HH:MM"
- .Value = xTime
- .Resize(2).Merge
- End With
- C = 2
- '迴圈:字典物件的KEY(關鍵字) 最大值 - 最小值.
- For X = Application.Max(D.KEYS) To Application.Min(D.KEYS) Step -1
- If D.EXISTS(X) Then '字典物件有這個KEY(關鍵字)
- If .Cells(1, C) = "" Then .Cells(1, C) = C - 1
- .Cells(R, C) = X
- .Cells(R, C).Interior.ColorIndex = 40
-
- .Cells(R + 1, C) = D(X)
- C = C + 1
- End If
- Next
- End With
- D.RemoveAll '重設,字典物件(紀錄成交價的公式的值)
-
- '這行的程式碼可刪除上一分鐘的資料,加速程式的運行
- Range("A" & Rows.Count).End(xlUp).CurrentRegion.Offset(1) = "" '如要保留可註解掉不必執行
- Application.EnableEvents = True
- End Sub
|
|
發表於 2016-2-3 09:41
| 
