Board logo

標題: [發問] 指定的時間插入相關數據 [打印本頁]
作者: cdkee    時間: 2014-4-7 14:23     標題: 指定的時間插入相關數據

請教各大大/版大，要在指定的時間插入相關數據(包括取出最大及最小數值)，VBA應如何寫，詳細見附件內容，謝謝!
[attach]17950[/attach]
作者: cdkee    時間: 2014-4-8 16:57

回復 1# cdkee

嘗試了一些例子，只做到按時間插入部份資料
[attach]17956[/attach]

再請教各大大，這裡找到"擷取最高最低"例子 和 "找尋指定時間插入相關資料"例子，應該如何結合才能做到要求，謝謝!
  1. '擷取最高最低
  2. Private Sub Worksheet_Calculate()

  4.     Dim Rng As Range

  6.     Static Msg As Boolean    '以 Static 陳述式宣告的變數，在程式執行期間，會一直保留內容。

  8.     If Weekday(Date, vbMonday) > 5 Or Time < #5:46:00 PM# Or Time > #11:00:00 PM# Then Exit Sub  '非營業日 或 非營業時間

  10.     If Msg = False Then

  12.         清除舊資料

  14.         Msg = True

  16.     End If

  18.     With Cells(Rows.Count, "C").End(xlUp)

  20.         If .Row = 7 Then

  22.             Set Rng = .Offset(1)

  24.         Else

  26.             Set Rng = .Cells

  28.         End If

  30.     End With

  32.     If Rng = "" Or Rng.Text <> Format([b5], "hh:mm") Then

  34.         If Rng <> "" Then Set Rng = Rng.Offset(1)

  36.         Rng = Format([b5], "hh:mm")

  38.         Rng(1, 2) = [B6].Text

  40.         Rng(1, 3) = [B6].Text

  42.     ElseIf Rng.Text = Format([b5], "hh:mm") Then

  44.         If [B6] > Rng(1, 2) Then Rng(1, 2) = [B6].Text

  46.         If [B6] < Rng(1, 3) Then Rng(1, 3) = [B6].Text

  48.     End If

  50. End Sub
複製代碼
  1. '找尋定時間插入相關資料
  2. Sub 資料輸入()
  3.     Dim E As Range
  4.     '''''''''''''''''''''''''''''''''''''
  5.     'Dim Ar()      'Ar陣列 ->  存入你要的數據
  6.     'Ar = Sheets("Table").Range("B2:D2").Value
  7.     '''''''''''''''''''''''''''''''''''''
  8.     Dim Ar(1 To 5)      'Ar陣列 ->  存入你要的數據
  9.     Ar(1) = [Table!B2]
  10.     Ar(2) = [Table!C2]
  11.     Ar(3) = [Table!D2]
  12.     Ar(4) = [Table!E2]
  13.     Ar(5) = [Table!A2]
  14.     If Minute(Time) Mod 1 = 0 Then
  15.         Set E = Sheets("1分K").Range("A:A").Find(TimeSerial(Hour(Time), Minute(Time), 0))
  16.         E.Offset(0, 1).Resize(1, UBound(Ar)).Value = Ar 'Minute(Time) Mod 1=0  每分鐘
  17.         
  18.        ElseIf Minute(Time) Mod 1 = 1 Then
  19.        E.Offset(0, 1).Resize(1, UBound(Ar)).Value = Ar
  20.     End If
  21.     'If Minute(Time) Mod 5 = 0 Then
  22.     '    Set E = Sheets("5分K").Range("A:A").Find(TimeSerial(Hour(Time), Minute(Time), 0))
  23.     '    E.Offset(0, 1).Resize(1, UBound(Ar)).Value = Ar 'Minute(Time) Mod 5=0  每5分鐘
  24.     'End If
  25.     'If Minute(Time) Mod 15 = 0 Then
  26.     '    Set E = Sheets("15分K").Range("A:A").Find(TimeSerial(Hour(Time), Minute(Time), 0))
  27.     '    E.Offset(0, 1).Resize(1, UBound(Ar)).Value = Ar 'Minute(Time) Mod 15=0  每15分鐘
  28.     'End If
  29.     If Time <= #4:15:00 PM# Then Application.OnTime TimeValue(Format(Time, "hh:MM:00")) + #12:01:00 AM#, "ThisWorkbook.資料輸入"
  30.     ' ***  #4:15:00 PM# 之前時間執行程式 ->資料輸入
  31.     Set E = Nothing    '
  32. End Sub
複製代碼
作者: cdkee    時間: 2014-4-10 11:58

版上再找到GBKEE版大建議的例子(#10)，加上以上兩個例子，再請大大指教如何改寫，感謝!
http://forum.twbts.com/viewthread.php?tid=7534&from=favorites
  1. '[策略記錄] 工作表的程式碼(重算事件 )

  3. Private Sub Worksheet_Calculate()

  5.     Static Msg As Boolean                      '用以判定是否為每日第一次執行

  7.     Static Time_Calculate As Date              '記錄每分鐘的時間

  9.     Static AR                                  '陣列:記錄成交價格

  11.     If Time < #8:30:00 AM# Then Exit Sub

  13.     Application.EnableEvents = False           '停止物件能觸發事件(Worksheet_Calculate)

  15.     If Msg = False Then

  17.         Time_Calculate = TimeSerial(Hour(Time), Minute(Time), 0) '每分鐘的時間

  19.         Range("A12").CurrentRegion.Offset(1) = ""                '清理昨日資料

  21.         ReDim AR(0)                                              '重新設為一元素

  23.     End If

  25.     Msg = True

  27.     If Time >= Time_Calculate + #12:01:00 AM# Then

  29.             With IIf([A13] = "", [A13], Cells(Rows.Count, 1).End(xlUp).Offset(1))

  31.                 .Cells(1, 1) = Time_Calculate                    '時間

  33.                 .Cells(1, 2) = AR(0)                             '開盤價

  35.                 .Cells(1, 3) = Application.Max(AR)               '最高價

  37.                 .Cells(1, 4) = Application.Min(AR)               '最低價

  39.                 .Cells(1, 5) = AR(UBound(AR))                    '收盤價

  41.             End With

  43.             Time_Calculate = TimeSerial(Hour(Time), Minute(Time), 0)

  45.             ReDim AR(0)

  47.     End If

  49.     If AR(UBound(AR)) <> "" Then ReDim Preserve AR(UBound(AR) + 1) '重新再加上一元素

  51.     AR(UBound(AR)) = [f2]                                          '記錄成交價格成交價

  53.     Application.EnableEvents = True           '恢復物件能觸發事件(Worksheet_Calculate)

  55. End Sub
複製代碼
作者: cdkee    時間: 2014-4-10 16:44

[attach]17975[/attach]
附件已經可做到大部份要求。
再請教大大，如何做到每個記錄時段開始時，即首個秒鐘>=00，及在"B4"有改變時，才開始記錄?謝謝!
作者: cdkee    時間: 2014-4-11 01:07

改了一些，仍然不行，請大大幫助指教，謝謝!
  1. Option Explicit

  3. Private Sub Worksheet_Calculate()

  5.    
  6. Dim target As Range

  8.      Set target = Sheets("Sheet2").Range("B4")

  10.      If Not Intersect(target, Sheets("Sheet2").Range("B4")) Is Nothing Then


  13.     Dim rng As Range
  14.    
  15.    
  16.     Static Msg As Boolean    '以 Static 陳述式宣告的變數，在程式執行期間，會一直保留內容。

  18.     If Weekday(Date, vbMonday) > 5 Then Exit Sub    '非營業日 或 非營業時間

  20.     If Msg = False Then

  22.         清除舊資料

  24.         Msg = True

  26.     End If
  27.    
  28.    
  29.    
  30.      
  31.      

  33.     With Cells(Rows.Count, "C").End(xlUp)

  35.         If .Row = 7 Then

  37.             Set rng = .Offset(1)

  39.         Else

  41.             Set rng = .Cells

  43.         End If

  45.     End With

  47.     If rng = "" Or rng.Text <> Format(Worksheets("Sheet1").[a2], "hh:mm") Then

  49.         If rng <> "" Then Set rng = rng.Offset(1)

  51.         rng = Format(Worksheets("Sheet1").[a2], "hh:mm")
  52.         
  53.         rng(1, 2) = [B6].Text '

  55.         rng(1, 3) = [B6].Text

  57.         rng(1, 4) = [B6].Text
  58.         
  59.         rng(1, 5) = [B6].Text '

  61.     ElseIf rng.Text = Format(Worksheets("Sheet1").[a2], "hh:mm") Then

  63.         If [B6] > rng(1, 3) Then rng(1, 3) = [B6].Text

  65.         If [B6] < rng(1, 4) Then rng(1, 4) = [B6].Text
  66.         
  67.         rng(1, 5) = [B6].Text '

  69.     End If

  71. End Sub

  73. Private Sub 清除舊資料()

  75.     On Error GoTo Er

  77.     If [營業日] <> Date Then            '檢查 定義名稱:"營業日"的值

  79.         Me.Names.Add "營業日", Date     '定義名稱:"營業日"的值為當日

  81.         If Weekday(Date, vbMonday) <= 5 Then Range([C8], [E8].End(xlDown)).Clear '營業日

  83.     End If

  85.     Exit Sub

  87. Er:  '處裡: 沒有定義名稱:"營業日"的錯誤

  89.      Me.Names.Add "營業日", Date        '定義名稱:"營業日"的值為當日

  91.      Resume Next                        '回到錯誤的下一個程式碼:繼續執行

  93. End Sub
複製代碼




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