返回列表 上一主題 發帖

這種依時間運算的巨集要如何寫??

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2014-11-16 15:31 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-11-16 15:43 編輯

回復 3# 藍天麗池

試試看
  1. Option Explicit
  2. Dim i As Integer '(短整數)資料型態
  3. 'Public i As interger => 出現使用者型態尚未定義, 正確: Integer
  4. Sub Ex()
  5.     Dim xTime As Date
  6.     If Time >= #8:46:00 AM# And Time <= #1:45:00 PM# Then
  7.         With Sheets("RTD").Cells(i + 2, "T")
  8.                     'T欄公式=IF(ISERROR(MATCH(U2,P:P,0)),"",MATCH(U2,P:P,0))
  9.             .Range("A1") = "=IF(ISERROR(MATCH(RC[1],P:P,0)),"""",MATCH(RC[1],P:P,0))"
  10.                     'U欄
  11.             .Range("B1") = IIf(Minute(Time) Mod 2 = 0, Application.Sum(Range("A1:C1")), Application.Sum(Range("A2:C2")))
  12.                     'V欄
  13.             .Range("C1") = Time
  14.                     'W欄公式=IF(ISERROR(INDIRECT("O"&T2)),"",INDIRECT("O"&T2))
  15.             .Range("D1") = "=IF(ISERROR(INDIRECT(""O""&RC[-3])),"""",INDIRECT(""O""&RC[-3]))"
  16.                     'X欄公式=IF(W2="","",IF(W2>54,-1,IF(W2<6,1,"")))
  17.             .Range("E1") = "=IF(RC[-1]="""","""",IF(RC[-1]>54,-1,IF(RC[-1]<6,1,"""")))"
  18.                     'Y欄公式=IF(ISERROR(INDIRECT("R"&T2)),Y1,INDIRECT("R"&T2))
  19.             .Range("F1") = "=IF(ISERROR(INDIRECT(""R""&RC[-5])),R[-1]C,INDIRECT(""R""&RC[-5]))"
  20.             .Resize(, 6) = .Resize(, 6).Value  '將公式回數值
  21.         End With
  22.         i = i + 1
  23.         xTime = Time + #12:01:00 AM#
  24.         If xTime <= #1:45:00 PM# Then Application.OnTime xTime, "EX"
  25.     ElseIf Time < #8:46:00 AM# Then
  26.         Application.OnTime #8:46:00 AM#, "EX"
  27.     Else
  28.         MsgBox "時間已過"
  29.     End If
  30. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2014-11-17 14:33 | 顯示全部帖子
回復 8# 藍天麗池

是這樣嗎?
  1. With Sheets("RTD").Cells(i + 2, "T").Resize(, 7)
  2.             .Offset(-1).Value = .Offset(-1).Value '上一列:將公式回數值
  3.             
  4.                     'T欄公式=IF(ISERROR(MATCH(U2,P:P,0)),"",MATCH(U2,P:P,0))
  5.             .Range("A1") = "=IF(ISERROR(MATCH(RC[1],P:P,0)),"""",MATCH(RC[1],P:P,0))"
  6.                     'U欄
  7.             .Range("B1") = IIf(Minute(Time) Mod 2 = 0, Application.Sum(Range("A1:C1")), Application.Sum(Range("A2:C2")))
  8.                     'V欄
  9.             .Range("C1") = Time
  10.                     'W欄公式=IF(ISERROR(INDIRECT("O"&T2)),"",INDIRECT("O"&T2))
  11.             .Range("D1") = "=IF(ISERROR(INDIRECT(""O""&RC[-3])),"""",INDIRECT(""O""&RC[-3]))"
  12.                     'X欄公式=IF(W2="","",IF(W2>54,-1,IF(W2<6,1,"")))
  13.             .Range("E1") = "=IF(RC[-1]="""","""",IF(RC[-1]>54,-1,IF(RC[-1]<6,1,"""")))"
  14.                     'Y欄公式=IF(ISERROR(INDIRECT("R"&T2)),Y1,INDIRECT("R"&T2))
  15.             .Range("F1") = "=IF(ISERROR(INDIRECT(""R""&RC[-5])),R[-1]C,INDIRECT(""R""&RC[-5]))"
  16.                     'Z欄公式=IF(ISERROR(Y2-Y1),"",Y2-Y1)
  17.             .Range("G1") = "=IF(ISERROR(RC[-1]-R[-1]C[-1]),"""",RC[-1]-R[-1]C[-1])"
  18.            
  19.         End With
  20.         
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2014-12-7 06:25 | 顯示全部帖子
回復 11# 藍天麗池
  1. Option Explicit
  2. Dim NextTime As Date
  3. Sub RecordPrice()
  4.     Dim i As Integer
  5.     i = Cells(2, Columns.Count).End(xlToLeft).Column
  6.     'i: 傳回工作表最右邊的儲存格, 向左到最後有資料的儲存格的欄號
  7.     'Cells(列號, 欄號).END(向左到最後有資料的儲存格)
  8.     'Columns.Count(工作表欄物件的總計)
  9.     With Range("t2")
  10.         If .Value = "" Then
  11.             .Cells = "公式A"          '你的公式
  12.             .Cells(2) = "公式B"       '下一列的公式
  13.         ElseIf i >= .Column Then      '
  14.              '這裡沒有.Cells 為這工作表以A1為基點的Cells
  15.             Cells(2, i) = Cells(2, i).Value
  16.             Cells(3, i) = Cells(3, i).Value
  17.             Cells(2, i + 1) = "公式A" '下一欄給公式
  18.             Cells(3, i + 1) = "公式B"
  19.         End If
  20.     End With
  21. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2014-12-7 10:13 | 顯示全部帖子
回復 13# 藍天麗池
查看VBA Offset 屬性 的說明
  1. .Offset( ,-1).Value = .Offset( ,-1).Value '左一欄:將公式回數值            
複製代碼
i: 傳回工作表最右邊的儲存格, 向左到最後有資料的儲存格的欄號
O欄在T欄的左邊不會影響的

如果5.修改程式增加公式數量，那6.的部分要修改嗎??
5增加公式數量，當然 6.的部分要修改所增加公式數量
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2014-12-7 14:26 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-12-7 14:30 編輯

回復 15# 藍天麗池
VBA公式文字可用巨集錄製: 在公式所在的儲存格作輸入的動作
  1. Sub RecordPrice()
  2.     Dim i As Integer, 公式(1 To 2)
  3.     i = Cells(2, Columns.Count).End(xlToLeft).Column
  4.     公式(1) = "=MATCH(R[-1]C,R3C6:R50000C6,0) + 1"
  5.     公式(2) = "=IF(SUMIF(INDIRECT(""D""&R2C[-1]+1):INDIRECT(""D""&R2C),RC9,INDIRECT(""E""&R2C[-1]+1):INDIRECT(""E""&R2C))=0,"""",SUMIF(INDIRECT(""D""&R2C[-1]+1):INDIRECT(""D""&R2C),RC9,INDIRECT(""E""&R2C[-1]+1):INDIRECT(""E""&R2C)))"
  6.     With Range("J2")
  7.         If .Value = "" Then
  8.             .Cells = 公式(1)         '你的公式"
  9.             .Cells(2).Resize(200) = 公式(2)
  10.         ElseIf i >= .Column Then      '
  11.             Cells(2, i) = Cells(2, i).Value
  12.             Cells(3, i).Resize(200) = Cells(3, i).Resize(200).Value
  13.             Cells(2, i + 1) = 公式(1)
  14.             Cells(3, i + 1).Resize(200) = 公式(2)
  15.         End If
  16.     End With
  17. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2014-12-8 20:41 | 顯示全部帖子
回復 17# 藍天麗池

之前有設定從8:45開始到13:45結束，這次沒看到
Sub RecordPrice() 套上不就可以了嗎?
你對VBA應該有認識了,多練習一下就會進步的.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2014-12-11 06:20 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-12-11 06:24 編輯

回復 20# 藍天麗池

問題出在這些券商的 API 函數  http://www.coco-in.net/thread-24599-1-1.html
請再自行詢問券商如何解決.
  1. Declare Function SKQuoteLib_Initialize Lib "SKQuoteLib.dll" (ByRef strID As Byte, ByRef strPass As Byte) As Long
  2. Declare Function SKQuoteLib_EnterMonitor Lib "SKQuoteLib.dll" () As Long
  3. Declare Function SKQuoteLib_AttachConnectionCallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
  4. Declare Function SKQuoteLib_AttachQuoteCallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
  5. Declare Function SKQuoteLib_AttachTicksCallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
  6. Declare Function SKQuoteLib_AttachBest5CallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
  7. Declare Function SKQuoteLib_RequestStocks Lib "SKQuoteLib.dll" (ByRef Page As Integer, ByVal Stocks As String) As Long
  8. Declare Function SKQuoteLib_RequestTicks Lib "SKQuoteLib.dll" (ByRef Page As Integer, ByVal Stock As String) As Long
  9. Declare Function SKQuoteLib_GetStockByNo Lib "SKQuoteLib.dll" (ByVal strStockNo As String, ByRef Stock As TStock) As Long
  10. Declare Function SKQuoteLib_GetStockByIndex Lib "SKQuoteLib.dll" (ByVal Market As Integer, ByVal Index As Integer, ByRef Stock As TStock) As Long
  11. Declare Function SKQuoteLib_GetTick Lib "SKQuoteLib.dll" (ByVal Market As Integer, ByVal Index As Integer, ByVal Ptr As Long, ByRef Tick As TTick) As Long
  12. Declare Function SKQuoteLib_GetBest5 Lib "SKQuoteLib.dll" (ByVal Market As Integer, ByVal Index As Integer, ByRef Best5 As TBest5) As Long
  13. Declare Function SKQuoteLib_AttachTicksGetCallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
  14. Declare Function SKQuoteLib_AttachBest5GetCallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
  15. Declare Function SKQuoteLib_GetKLine Lib "SKQuoteLib.dll" (ByVal strStockNo As String, ByVal KLineType As Integer) As Long
  16. Declare Function SKQuoteLib_AttachKLineDataCallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
  17. Declare Function SKQuoteLib_RequestServerTime Lib "SKQuoteLib.dll" () As Long
  18. Declare Function SKQuoteLib_GetServerTime Lib "SKQuoteLib.dll" (ByRef ServerTime As CFormat05) As Long
  19. Declare Function SKQuoteLib_AttchServerTimeCallBack Lib "SKQuoteLib.dll" (ByVal Func As Long) As Long
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 2014-12-24 12:02 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-12-24 12:29 編輯

回復 25# 藍天麗池
試試看
  1. Option Explicit
  2. Sub RecordPrice()
  3.     Dim WR As Long, I As Byte, SH As Worksheet
  4.     Set SH = shtRTD '工作表物件模組的名稱
  5.     Set SH = Sheets("RTD") '活頁簿工作表的名稱
  6.     With SH
  7.         .Activate
  8.         If IsError(.Range("F2")) Or IsError(.Range("G2")) Then Exit Sub
  9.         If .Range("F2") < 20 Then Exit Sub
  10.         WR = .Range("A1").End(xlDown).Row + 1
  11.         If WR = 3 Or Application.Max(.Range("B2").Resize(, 10)) > 700 Then
  12.             .Cells(WR, 1).Resize(, 11) = .Range("A2").Resize(, 11).Value
  13.             With ActiveWindow
  14.                 If Intersect(SH.Cells(WR, "A"), .VisibleRange) Is Nothing Then
  15.                     SH.Cells(WR, "A").Select
  16.                 End If
  17.             End With
  18.         End If
  19.     End With
  20. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
9#
發表於 2014-12-25 08:23 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-12-25 08:48 編輯

回復 28# 藍天麗池

是這樣嗎?
  1. Sub RecordPrice()
  2.     Dim WR As Long, R As Long
  3.     Dim I As Long
  4.     WR = Range("A1").End(xlDown).Row + 1
  5.     [A2] = TimeValue(Now)
  6.     For I = 1 To 24
  7.         Cells(WR, I) = Cells(2, I)
  8.     Next 'I
  9.     With ActiveWindow
  10.         If Intersect(Cells(WR, "A"), .VisibleRange) Is Nothing Then
  11.            Cells(WR, "A").Select
  12.         End If
  13.         .SmallScroll .VisibleRange.Cells.End(xlDown).Row - .VisibleRange.Cells(1).Row
  14.     End With
  15. End Sub
複製代碼
還是這樣?
  1. With ActiveWindow
  2.         If Intersect(Cells(WR, "A"), .VisibleRange) Is Nothing Then .SmallScroll 1
  3.     End With
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2015-1-11 16:34 | 顯示全部帖子
回復 32# 藍天麗池
試試看
  1. Sub RecordPrice()
  2.     Application.ScreenUpdating = False
  3.     Calculate
  4.     Application.ScreenUpdating = True
  5. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 每天無所事事，是人生的消費者，積極、有用才是人生的創造者。
返回列表 上一主題