將資料改為觸發型式

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

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

上傳資料.rar (43.06 KB)

樓主熱帖

初新者~指教囉~

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 276
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-22

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2013-12-2 15:09 | 只看該作者

回復 1# wl02353427

Public NameOfThisProcedure
Public NextTime
Sub Stop_Update()
Yn = MsgBox("確定停止" & NameOfThisProcedure & "程序" & Chr(10) & NextTime & "的更新?", vbYesNo)
If Yn = 6 Then Application.OnTime EarliestTime:=NextTime, Procedure:=NameOfThisProcedure, schedule:=False
End Sub
Sub Awesome()
'****************************截取資料並記錄****************************'
Dim SG As SparklineGroup
Dim SL As Sparkline
Dim WSD As Worksheet
Dim WSL As Worksheet
Dim WSQ As Worksheet
Set WSQ = Worksheets("工作表1")
hiji = Now()
WaitSec = 30 '延遲時間
NameOfThisProcedure = "Awesome"
NextTime = Now + TimeSerial(0, 0, WaitSec) ' 延遲
Application.OnTime EarliestTime:=NextTime, Procedure:=NameOfThisProcedure ' 利用OnTime指令排定 Awesome 的執行時間
WSQ.Range("B3").QueryTable.Refresh BackgroundQuery:=False '重新整理web查詢
Application.Wait (Now + TimeValue("0:00:05")) ' 確認資料更新
NextRow = WSQ.Cells(Rows.Count, 2).End(xlUp).Row + 1
WSQ.Range("B3:K3").Copy WSQ.Cells(NextRow, 2)
'**********************************************************************'
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("工作表2").Delete
On Error GoTo 0
Set WSD = Worksheets("工作表1") ' 資料讀取
Set WSL = ActiveWorkbook.Worksheets.Add ' 儀錶板輸出
WSL.Name = "工作表2"
WSL.Select
'***儀錶板大小***'
With WSL.Range("B2")
.ColumnWidth = 100 ' 高度
.RowHeight = 100 ' 寬度
End With
'****標題名稱****'
With WSL.Range("B1")
.Value = Array("張數")
.HorizontalAlignment = xlCenter
.ColumnWidth = 39
.Offset(1, 0).RowHeight = 200
End With
Set SG = WSL.Range("B2").SparklineGroups.Add(Type:=xlSparkLine, SourceData:="工作表1!G8:G" & NextRow)
SG.SeriesColor.Color = RGB(0, 0, 255) ' 線條顏色
Set SL = SG.Item(1)
'***背景顏色***'
With WSL.Range("B2").Interior
.Color = RGB(255, 255, 255)
.TintAndShade = 0
End With
Set SL = SG.Item(1)
'***最大最小值***'
Set AF = Application.WorksheetFunction
AllMin = AF.Min(WSD.Range("G8:G65536")) ' 指定區域中選出最小值
AllMax = AF.Max(WSD.Range("G8:G65536"))
AllMin = Int(AllMin) - AllMin ' 整數設定
AllMax = Int(AllMax)
With SG.Axes.Vertical
.MinScaleType = xlSparkScaleCustom
.MaxScaleType = xlSparkScaleCustom
.CustomMinScaleValue = AllMin
.CustomMaxScaleValue = AllMax
End With
'***[A2]上下間距***'
With WSL.Range("A2")
.Value = AllMax & vbLf & vbLf & vbLf & vbLf _
& vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & AllMin
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.Font.Size = 8
.Font.Bold = True
.WrapText = True
End With
'***其他設定***'
Worksheets("工作表2").Range("B3") = "更新日期 : " & hiji
Number = WSD.Range("G8:G" & NextRow).Count
Worksheets("工作表1").Range("M2") = "資料筆數 :"
Worksheets("工作表1").Range("N2") = Number
Workbooks(1).Save
Set WSQ = Nothing
Set QSL = Nothing
End Sub