藍天麗池

回復 78# c_c_lai

下載 (62.55 KB)

2016-4-10 07:46

上圖示股票10的測試結果，黑框的部分沒有往下複製，紅框的部分為一組(B2-E2、F2-I2...等等)，是總量變動後要往下紀錄的欄位

c_c_lai

回復 81# 藍天麗池
明白了，有事出去一下 (買無糖豆漿)。
回頭再修正。

藍天麗池

回復 82# c_c_lai


    C大不急，你先忙

c_c_lai

回復  c_c_lai

上圖示股票10的測試結果，黑框的部分沒有往下複製，紅框的部分為一組(B2-E2、F2-I2...等 ...
藍天麗池 發表於 2016-4-10 07:47

下載 (113.19 KB)

2016-4-10 13:29

GBKEE

回復 84# c_c_lai
39帖  補上非營業時間不執行程式

1. Private Sub Worksheet_Calculate()
   
2.         Dim Rng As Range, E As Variant
   
3.         On Error Resume Next ' 檔案開啟時 DEE傳回錯誤值
   
4.         Set Rng = UsedRange.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
   
5.         If Not Rng Is Nothing Then Exit Sub
   
6.         On Error GoTo 0 '開盤不再處理程式碼的錯誤
   
7.         If Time < #9:00:00 AM# Or Time > #1:31:00 PM# Then Exit Sub '非營業時間
   
8.         For Each E In Me.Names
   
9.             If E.Name Like "*TotalVolume*" Then   '總量的名稱
   
10.                 If Range(E.Name) > 0 Then
    
11.                     With Cells(Rows.Count, Range(E.Name).Column).End(xlUp)  ''總量名稱所在的最底列往上到有資料的儲存格
    
12.                             If .Row = 2 Or .Row > 2 And .Value <> Range(E.Name).Value Then
    
13.                                 .Offset(1).Cells(1, -2).Resize(, 4) = Range(E.Name).Cells(, -2).Resize(, 4).Value
    
14.                             End If
    
15.                     End With
    
16.                 End If
    
17.             End If
    
18.         Next
    
19. End Sub

複製代碼

c_c_lai

回復 83# 藍天麗池
回復 85# GBKEE
附上 股票10A.rar 以及 股票10B.rar 兩個檔案；
股票10A.rar 是我的 (Worksheet_Change()) 程式，
股票10B.rar 則是 GBKEE 大大的 (Worksheet_Calculate())
程式，且加入了 非開盤時間的考量。 A、B 是兩個
不同的程式模組，明天測試完畢向我倆報告心得結果。
股票10A.rar (21.88 KB)

下載次數: 1

2016-4-10 15:02

股票10B.rar (23.44 KB)

下載次數: 1

2016-4-10 15:02

c_c_lai

回復 83# 藍天麗池
我的部分：
ThisWorkbook：

1. Option Explicit
   
2. 
   
3. Private Sub Workbook_Open()
   
4.     '  Nothing to do (保留)
   
5. End Sub

複製代碼

shtRTD(RTD)表單:

1. Option Explicit
   
2. 
   
3. Private Sub Worksheet_Change(ByVal Target As Range)
   
4.     '  當 Target (總量) 欄位有異動時， 則去呼叫 RecordPrice 的方法 (Method)。
   
5.    
   
6.     If Target.Row = 2 And Target.Column Mod 4 = 0 Then
   
7.         Call RecordPrice(Target)
   
8.     End If
   
9. End Sub

複製代碼

Module1:

1. Option Explicit
   
2. 
   
3. Sub RecordPrice(TG As Range)
   
4.     Dim WR As Long, cts As Long
   
5.    
   
6.     With Sheets("RTD")
   
7.         If .Range("A1") < 1 Then Exit Sub
   
8.    
   
9.         cts = TG.Column
   
10.    
    
11.         WR = .Cells(Rows.Count, cts).End(xlUp).Row + 1         '  求取該異動欄位的最後一筆紀錄列位置
    
12.         
    
13.         If WR = 3 Or .Cells(WR - 1, cts) <> .Cells(2, cts) Then
    
14.             .Cells(WR, cts).Offset(, -3).NumberFormatLocal = "hh:mm:ss"   '  設定儲存格格式 (時間)
    
15.             
    
16.             .Cells(WR, cts).Offset(, -2).Resize(, 3) = .Range(TG.Address).Offset(, -2).Resize(, 3).Value
    
17.         End If
    
18.     End With
    
19. End Sub
    
20. 
    
21. Sub 時間()
    
22.     Sheets("RTD").Cells(2, 1) = WorksheetFunction.Text(Now(), "hh:mm:ss")
    
23.     Application.OnTime Now() + TimeValue("00:00：01"), "時間"
    
24. End Sub
    
25. 
    
26. Sub Cls()
    
27.     With Sheets("RTD")
    
28.         .Range("A3:OK5000").ClearContents
    
29.         .[A3].Select
    
30.     End With
    
31. End Sub

複製代碼

c_c_lai

回復 83# 藍天麗池
.

c_c_lai

回復 83# 藍天麗池
.GBKEE 大大的程式一直貼不上
自行看程式吧！

c_c_lai

回復 81# 藍天麗池
GBKEE 大大的程式：
ThisWorkbook：[code]Option Explicit

Private Sub Workbook_Open()
    Dim xRng As Range, First_Aaddres  As String, xRng_Name As String
    Dim nm As Variant
   
    Application.RTD.ThrottleInterval = 0
    Application.Calculation = xlCalculationAutomatic     '  自動重算
   
    '  清除「名稱管理員」內的所有內容
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next nm
   
    With Sheets("RTD")
        '  檔案開啟時 定義了 Sheets("RTD") 所有總量 DDE 公式的儲存格
        Set xRng = .Rows(2).Cells.Find("TotalVolume", LookIn:=xlFormulas)
        
        If Not xRng Is Nothing Then
            First_Aaddres = xRng.Address
            
            Do
                xRng_Name = Split(xRng.Formula, "'")(1)
                xRng_Name = "TotalVolume" & Split(xRng_Name, ".")(0)
                .Names.Add xRng_Name, xRng       '  名稱定義: 所有總量的 DDE 公式的儲存格