標題: 將資料改為觸發型式 [打印本頁]

---

作者: wl02353427    時間: 2013-12-1 17:37     標題: 將資料改為觸發型式

本帖最後由 wl02353427 於 2013-12-1 17:38 編輯

我想將擷取資料改為觸發式或在設定期間內執行擷取，就是以一個控制器來啟動和停止，可是改來改去一直失敗...目前只會一直抓...然後得自己進入vba按停止...可否有大大可以幫幫忙

---

作者: Hsieh    時間: 2013-12-2 15:09

回復 1# wl02353427

1. Public NameOfThisProcedure
   
2. Public NextTime
   
3. Sub Stop_Update()
   
4. Yn = MsgBox("確定停止" & NameOfThisProcedure & "程序" & Chr(10) & NextTime & "的更新?", vbYesNo)
   
5. If Yn = 6 Then Application.OnTime EarliestTime:=NextTime, Procedure:=NameOfThisProcedure, schedule:=False
   
6. End Sub
   
7. Sub Awesome()
   
8. '****************************截取資料並記錄****************************'
   
9.     Dim SG As SparklineGroup
   
10.     Dim SL As Sparkline
    
11.     Dim WSD As Worksheet
    
12.     Dim WSL As Worksheet
    
13.     Dim WSQ As Worksheet
    
14.     Set WSQ = Worksheets("工作表1")
    
15.    
    
16.     hiji = Now()
    
17.    
    
18.     WaitSec = 30 '延遲時間
    
19.     NameOfThisProcedure = "Awesome"
    
20.    
    
21. 
    
22.     NextTime = Now + TimeSerial(0, 0, WaitSec) ' 延遲
    
23.    
    
24.     Application.OnTime EarliestTime:=NextTime, Procedure:=NameOfThisProcedure ' 利用OnTime指令排定 Awesome 的執行時間
    
25.    
    
26.     WSQ.Range("B3").QueryTable.Refresh BackgroundQuery:=False '重新整理web查詢
    
27.    
    
28.     Application.Wait (Now + TimeValue("0:00:05")) ' 確認資料更新
    
29. 
    
30.     NextRow = WSQ.Cells(Rows.Count, 2).End(xlUp).Row + 1
    
31.     WSQ.Range("B3:K3").Copy WSQ.Cells(NextRow, 2)
    
32.    
    
33. '**********************************************************************'
    
34. 
    
35. On Error Resume Next
    
36.    Application.DisplayAlerts = False
    
37.    Worksheets("工作表2").Delete
    
38. On Error GoTo 0
    
39. 
    
40. Set WSD = Worksheets("工作表1") ' 資料讀取
    
41. Set WSL = ActiveWorkbook.Worksheets.Add ' 儀錶板輸出
    
42.     WSL.Name = "工作表2"
    
43. 
    
44. WSL.Select
    
45. 
    
46. '***儀錶板大小***'
    
47. With WSL.Range("B2")
    
48.     .ColumnWidth = 100 ' 高度
    
49.     .RowHeight = 100  ' 寬度
    
50. End With
    
51. 
    
52. '****標題名稱****'
    
53. With WSL.Range("B1")
    
54.     .Value = Array("張數")
    
55.     .HorizontalAlignment = xlCenter
    
56.     .ColumnWidth = 39
    
57.     .Offset(1, 0).RowHeight = 200
    
58. End With
    
59. 
    
60. Set SG = WSL.Range("B2").SparklineGroups.Add(Type:=xlSparkLine, SourceData:="工作表1!G8:G" & NextRow)
    
61.     SG.SeriesColor.Color = RGB(0, 0, 255) ' 線條顏色
    
62. 
    
63. Set SL = SG.Item(1)
    
64. 
    
65. '***背景顏色***'
    
66. With WSL.Range("B2").Interior
    
67.     .Color = RGB(255, 255, 255)
    
68.     .TintAndShade = 0
    
69. End With
    
70.    
    
71. Set SL = SG.Item(1)
    
72. 
    
73. '***最大最小值***'
    
74. Set AF = Application.WorksheetFunction
    
75.     AllMin = AF.Min(WSD.Range("G8:G65536")) ' 指定區域中選出最小值
    
76.     AllMax = AF.Max(WSD.Range("G8:G65536"))
    
77.     AllMin = Int(AllMin) - AllMin ' 整數設定
    
78.     AllMax = Int(AllMax)
    
79. 
    
80. With SG.Axes.Vertical
    
81.     .MinScaleType = xlSparkScaleCustom
    
82.     .MaxScaleType = xlSparkScaleCustom
    
83.     .CustomMinScaleValue = AllMin
    
84.     .CustomMaxScaleValue = AllMax
    
85. End With
    
86. 
    
87. '***[A2]上下間距***'
    
88. With WSL.Range("A2")
    
89.      .Value = AllMax & vbLf & vbLf & vbLf & vbLf _
    
90.             & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & AllMin
    
91.      .HorizontalAlignment = xlRight
    
92.      .VerticalAlignment = xlTop
    
93.      .Font.Size = 8
    
94.      .Font.Bold = True
    
95.      .WrapText = True
    
96.     End With
    
97. 
    
98. '***其他設定***'
    
99. Worksheets("工作表2").Range("B3") = "更新日期 : " & hiji
    
100. 
     
101. Number = WSD.Range("G8:G" & NextRow).Count
     
102. Worksheets("工作表1").Range("M2") = "資料筆數 :"
     
103. Worksheets("工作表1").Range("N2") = Number
     
104. 
     
105. Workbooks(1).Save
     
106. 
     
107. Set WSQ = Nothing
     
108. Set QSL = Nothing
     
109. 
     
110. End Sub

複製代碼

---

作者: wl02353427    時間: 2013-12-4 18:22

回復 2# Hsieh

感謝超級版主:'( 一直嘗試寫一個控制器可是都失敗，萬分感謝。Orz

---

作者: ML089    時間: 2013-12-4 20:25

回復 2# Hsieh

我的EXCEL是2007版，執行後出現錯誤，不知道還要設定哪些東東

[attach]16962[/attach]

---

作者: stillfish00    時間: 2013-12-4 23:33

本帖最後由 stillfish00 於 2013-12-4 23:35 編輯

回復 4# ML089
SparklineGroup 是 Excel 2010 新增的物件，估計2007是沒辦法直接用了。

---

作者: ML089    時間: 2013-12-5 00:23

回復 5# stillfish00

了解! 謝謝你的回覆

---

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