On Timeメソッド？で更新されません。

質問

On Timeメソッド？で更新されません。

現在Web上にあった例を参考に
下記の様にホワイトボード解析シートのA1セルに
20秒ごとに現在時刻を表示させています。

これを応用して、違うシートに
１７：００に天気というマクロを実行するよう
作成したのですが上手くいきませんでした。

Sub Auto_Open()とSub auto_close()のtargetTimeを
targetTime = TimeValue("17:00")

Macro7を天気

としたのですが、なぜ更新されなかったか分かる方がいらっしゃいましたら
ご教授下さい。

Sub Auto_Open()
Dim TargetTime, WaitTime
TargetTime = Now + TimeValue("00:00:01")
WaitTime = TimeValue("00:00:10")
Application.OnTime TargetTime, "Macro7", WaitTime
End Sub

Sub Macro7()
On Error Resume Next
Worksheets("ホワイトボード解析").Range("A1").Calculate
Application.OnTime Now + TimeValue("00:00:20"), "Macro7", TimeValue("00:00:10")
'↑TimeValueの最初の方をへんこうする事で時間が変わる
End Sub

Sub auto_close()
Dim i As Integer, TargetTime
On Error Resume Next
For i = 1 To 10
TargetTime = Now + TimeValue("00:00:" & Application.Text(i, "00"))
Application.OnTime TargetTime, "Macro7", , False
Next i
End Sub

回答No.10

Wendy02 · ベストアンサー

解説は、次に続けます。

'Option Explicit
Private myTime As Date 'モジュールの先頭に置く
Private WaitTime As Date
Private flg As Boolean
Sub Auto_Open()
　myTime = Now + TimeSerial(0, 0, 1)
　WaitTime = myTime + TimeSerial(0, 0, 10)
　Application.OnTime myTime, "Macro7", WaitTime
　Call Ontime_Set
End Sub
Sub Macro7()
　Worksheets("Sheet1").Range("A1").Calculate
　DoEvents
　myTime = Now + TimeSerial(0, 0, 1)
　WaitTime = myTime + TimeSerial(0, 0, 10)
　Application.OnTime myTime, "Macro7", WaitTime
End Sub
Sub Auto_Close()
　On Error Resume Next
　　 Application.OnTime myTime, "Macro7", WaitTime, False
　On Error GoTo 0
End Sub
Sub Ontime_Set()
　If flg = False Then
　　flg = True
　　'時間設定
　　myTime = Date + TimeSerial(18, 35, 0)
　　If myTime < Now Then
　　　MsgBox "設定時間が過ぎています。", vbExclamation
　　　flg = False
　　　Exit Sub
　　End If
　ElseIf flg = True Then
　　flg = False
　Else
　　Exit Sub
　End If
　Application.OnTime myTime, "WeatherForcast", myTime + TimeSerial(0, 0, 10), True
　Beep
End Sub
Sub WeatherForcast()
　Application.StatusBar = "天気予報変更中" 'ステータスバーに出てくる
　 With Worksheets("Sheet1")
　　　 .Select
　　If .QueryTables.Count > 1 Then
　　　.QueryTables(1).Refresh BackgroundQuery:=False
　　Else
　　　With .QueryTables.Add(Connection:= _
　　　　"URL; http://weather.yahoo.co.jp/weather/jp/11/4310.html", Destination:=Range( _
　　"A5"))
　　.Name = "4310_6"
　　.FieldNames = True
　　.RowNumbers = False
　　.FillAdjacentFormulas = False
　　.PreserveFormatting = True
　　.RefreshOnFileOpen = False
　　.BackgroundQuery = False
　　.RefreshStyle = xlOverwriteCells
　　.SavePassword = False
　　.SaveData = True
　　.AdjustColumnWidth = True
　　.RefreshPeriod = 0
　　.WebSelectionType = xlEntirePage
　　.WebFormatting = xlWebFormattingNone
　　.WebPreFormattedTextToColumns = True
　　.WebConsecutiveDelimitersAsOne = True
　　.WebSingleBlockTextImport = False
　　.WebDisableDateRecognition = False
　　.WebDisableRedirections = False
　　.Refresh BackgroundQuery:=False
　End With
　　End If
　End With
　Application.StatusBar = False
End Sub

お礼

完璧です！全てが思い通りに動いています！
ありがとうございました。

感動です！！

回答No.12

Wendy02

付け足し。そのままにしてしまうのももったいないので、単独で試してみて、分解して研究してみてください。以下を作るのにあると便利な道具は、テキストエディタ(Notepad++ が最適。ただし日本語版のみ。最新バージョンではない）、IEならDebugBarのアドオン

Sub GetWeatherReport()
　Dim ret As Variant
　Dim objHTTP As Object
　Dim HTTPlog As String
　Dim c As Variant
　With ActiveSheet
　　.Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Resize(, 4).ClearContents
　Const strURL As String = "http://weather.yahoo.co.jp/weather/jp/11/4310.html"
　On Error Resume Next
　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　objHTTP.Open "GET", strURL, False
　objHTTP.Send
　ret = objHTTP.Status
　On Error GoTo 0
　If ret >= 200 And ret < 300 Then
　　HTTPlog = objHTTP.ResponseText
　　Call LogCutters(HTTPlog)
　　For Each c In .Range("A1").Resize(, 4)
　　　 c.EntireColumn.AutoFit
　　Next
　Else
　　MsgBox "アクセスに失敗しました。", vbCritical
　End If
　End With
End Sub

Private Sub LogCutters(ByVal HTTPlog As String)
　Dim Ar1 As Variant, Ar As Variant
　Dim n As Variant, myData(3) As Variant
　Dim i As Long, j As Long, a As Variant
　Dim buf As String
　Ar = Split(HTTPlog, "yjw_table", , 1)
　For Each n In Array(1, 4)
　Ar1 = Split(Ar(n), "tr align=center", , 1)
　　For Each a In Ar1
　i = InStr(1, a, "月")
　If i > 0 And j = 0 Then
　　myData(0) = Mid(a, i - 1, InStr(i, a, "<") - i + 1)
　　j = j + 1
　End If
　i = InStr(1, a, "alt=")
　If i > 0 And j = 1 Then
　　myData(1) = Mid(a, i + 5, InStr(i, a, ">") - i - 6)
　　j = j + 1
　End If
　i = InStr(1, a, "最高")
　If i > 0 And j = 2 Then
　　buf = Mid(a, i, InStr(i, a, "</font") - i)
　　buf = Replace(buf, "<br>", " ", , , 1)
　　myData(2) = Replace(buf, vbLf, "")
　　j = j + 1
　End If
　i = InStr(1, a, "最低")
　If i > 0 And j = 3 Then
　　buf = Replace(n, vbCrLf, "")
　　buf = Mid(a, i, InStr(i, a, "</font") - i)
　　buf = Replace(buf, "<br>", " ", , , 1)
　　myData(3) = Replace(buf, vbLf, "")
　　j = j + 1
　End If
　If j >= 4 Then Exit For
　　Next
　　 ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4).Value = myData
　　 Erase myData
　　 i = 0: j = 0
　 Next
End Sub

お礼

本当に手取り足取りありがとうございました。

こちらも今後試してみたいと思います。

回答No.11

Wendy02

Sub 天気() は、Sub WeatherForcast()　に変更しました。私の環境では、なぜかうまく動かないからです。そして、私が考えていたマクロは、試してみましたが、安定性が悪くてうまくいきませんでした。

それで、そのまま、今と同じ形式のもので使いました。私としては、無念というところです。

Auto_Close()の終了する場合のループは必要ありません。調べてみましたが、ひとつしか残っていません。

Calculate で動かすセルは、このようにしてみました。
=TEXT(NOW(),"hh:mm:ss")

TimeValue の代わりに、TimeSerialを使っている理由は特にありませんが、最近、私は、こちら側にしているだけです。

出来れば、Yahooの天気予報を取得するマクロを新たに作りたいとは思うのですが、巨大なマクロになりそうです。

回答No.9

Wendy02

マクロを見せていただきました。両方と書かれていたので、おやっと思いました。なるほど、あくまでも、時刻表示マクロは捨てなかったのですね。それは、少し、時間をください。単独で動かすなら、今のままでもよいのですが、そうでない場合は、一種のイベントを新たに作ることと同じことですから、それをセルに表示させるのは、ハイレベルのマクロのひとつだと思っています。私も、すぐに出来ませんので、ちょっとお時間ください。

Private myData(3) As Variant
なお、現在の設定で、この変数は生きていません。私の作った、もう一つのマクロの中で使います。本日の、日付、天気、最高温度、最低温度を入れるためのものです。

回答No.8

Wendy02

>Auto_Openを実行しない場合は天気予報が更新されません。
>頑張ったのですが結局行き詰ってしまいました。

私にはその状況が分かりません。前回、ki-aaa さんのやりとりでも同じものがありましたね。何か、それを動かすための情報が出ていないようですね。

Auto_Open というのは、ファイルを[マニュアル]で開いた時に起動するものです。Auto_Open というのは、開いた時に付けられたチャイムのようなものです。開くと作動し、マクロの場合は実行・設定されます。

Excelを起動していない状態、もしく、ファイルを開いていない状態というのなら、コードとしては、基本的な作り方が変わってきます。(この二つは、VBAのコードとしては、別です。）

もしも、何もしないで、お天気情報を取得する、自動起動する場合は、タスクで設定します。しかし、Excelが起動している状態では、うまくいかないことがあります。インターネット検索でも、ここらのコードは、まったくといってヒットしないはずです。

なお、「天気」マクロでは、QueryTablesのオブジェクトが作成されていますが、二度目もうまくいくでしょうか？

補足

ありがとうございました！！無事両方とも表示することが出来ました。
Sub Auto_Oepn()を一緒にした（以下のマクロ）ところ上手くいきました。
おかしい箇所がありましたらご教授願います。

手取り足取りありがとうございました。

天気マクロですが、外部クエリ？を自動保存マクロで設定していました。
やはりエラーが出てしまいました。

差し出がましいようですが、お教えいただけると幸いです。

また、マクロ初心者なので作成していて解らないことが一杯あります。
検索や書籍で解決しないことがありましたらお世話になるかと思います。
今回は大変ありがとうございました。

'//
'Option Explicit

Private myTime As Date 'モジュールの先頭に置く
Private flg As Boolean
Private myData(3) As Variant

Sub Auto_Open()
Dim TargetTime, WaitTime
TargetTime = Now + TimeValue("00:00:01")
WaitTime = TimeValue("00:00:10")
Application.OnTime TargetTime, "Macro7", WaitTime
Call Ontime_Set
End Sub
'Close も必要でしたら、付け加えください。

Sub Macro7()
On Error Resume Next
Worksheets("Sheet1").Range("A1").Calculate
Application.OnTime Now + TimeValue("00:00:01"), "Macro7", TimeValue("00:00:10")
'↑TimeValueの最初の方をへんこうする事で時間が変わる
End Sub

Sub auto_close()
Dim i As Integer, TargetTime
On Error Resume Next
For i = 1 To 10
TargetTime = Now + TimeValue("00:00:" & Application.Text(i, "00"))
Application.OnTime TargetTime, "Macro7", , False
Next i
End Sub

Sub Ontime_Set()
If flg = False Then
flg = True
myTime = Date + TimeSerial(13, 49, 0)
If myTime < Now Then
MsgBox "設定時間が過ぎています。", vbExclamation
flg = False
Exit Sub
End If
ElseIf flg = True Then
flg = False
Else
Exit Sub
End If
Erase myData()
Application.OnTime myTime, "myPro", myTime + TimeSerial(0, 0, 10), True
Beep
End Sub

Sub myPro()
Call 天気
End Sub

Sub 天気()
'
'
Worksheets("Sheet1").Activate
Range("A1").Select
MsgBox "天気予報変更中"
End Sub

Sub Ontime_Reset()
'タイマーリセット
On Error Resume Next
Application.OnTime EarliestTime:=myTime, _
Procedure:="mPro", Schedule:=False
If Err.Number > 0 Then
MsgBox "OnTime設定はされていません。", 64
Err.Clear
flg = False
Else
MsgBox myTime & "の設定は解除されました。", 64
flg = False
myTime = Empty
End If
End Sub

回答No.7

Wendy02

そろそろ、17:00の時間も近づきましたので、こちらからアップさせていただきます。
以下、GetWeatherReportという、マクロは、掲示していませんが、ご反応があれば、別途、Yahooの天気情報を取得するマクロは出します。

'//
'Option Explicit

Private myTime As Date 'モジュールの先頭に置く
Private flg As Boolean
Private myData(3) As Variant

Sub Auto_Oepn()
　Call Ontime_Set
End Sub
'Close も必要でしたら、付け加えください。

Sub Ontime_Set()
　If flg = False Then
　flg = True
　myTime = Date + TimeSerial(17, 0, 0)
　If myTime < Now Then
　　MsgBox "設定時間が過ぎています。", vbExclamation
　　flg = False
　　Exit Sub
　End If
　ElseIf flg = True Then
　　flg = False
　Else
　　Exit Sub
　End If
　Erase myData()
　Application.OnTime myTime, "myPro", myTime + TimeSerial(0, 0, 10), True
　Beep
End Sub

Sub myPro()
　Call 天気　'ここに実行するマクロを入れます。(GetWeatherReport)
　flg = False
　myTime = 0
　If myData(0) <> "" Then
　　Range("A1").Resize(, 4).Value = myData
　　flg = False
　End If
End Sub

Sub Ontime_Reset()
'タイマーリセット
On Error Resume Next
Application.OnTime EarliestTime:=myTime, _
　　Procedure:="mPro", Schedule:=False
If Err.Number > 0 Then
　MsgBox "OnTime設定はされていません。", 64
　Err.Clear
　flg = False
Else
　MsgBox myTime & "の設定は解除されました。", 64
　flg = False
　myTime = Empty
End If
End Sub

補足

返答が遅くなり大変申し訳ございませんでした。

予めAuto_Openのマクロを実行しておく事で
ホワイトボード解析というシートのＡ１にNOW関数を更新させ、
天気予報シートに天気予報の情報が指定時刻に更新させる事ができました。

しかし、Auto_Openを実行しない場合は天気予報が更新されません。
頑張ったのですが結局行き詰ってしまいました。

'//
'Option Explicit

Private myTime As Date 'モジュールの先頭に置く
Private flg As Boolean
Private myData(3) As Variant

Sub Auto_Oepn()
Call Ontime_Set
End Sub
'Close も必要でしたら、付け加えください。

Sub Ontime_Set()
If flg = False Then
flg = True
myTime = Date + TimeSerial(19, 25, 0)
If myTime < Now Then
MsgBox "設定時間が過ぎています。", vbExclamation
flg = False
Exit Sub
End If
ElseIf flg = True Then
flg = False
Else
Exit Sub
End If
Erase myData()
Application.OnTime myTime, "myPro", myTime + TimeSerial(0, 0, 10), True
Beep
End Sub

Sub myPro()
Call 天気
End Sub

Sub 天気()
'
' 天気 Macro
' マクロ記録日 : 2009/1/29 ユーザー名 : 美徳
'
Worksheets("天気予報").Activate
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://weather.yahoo.co.jp/weather/jp/11/4310.html", Destination:=Range( _
"A1"))
.Name = "4310_6"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

flg = False
myTime = 0
If myData(0) <> "" Then
Range("A1").Resize(, 4).Value = myData
flg = False
End If
End Sub

Sub Ontime_Reset()
'タイマーリセット
On Error Resume Next
Application.OnTime EarliestTime:=myTime, _
Procedur

回答No.6

Wendy02

#5の回答者です。

>一つの投稿で複数の質問をしている方が、「一つの投稿で一つの質問にしろ」と
>お叱りを受けているのを見た為、分けさせていただきました。

関連性のないものは、別けるべきですが、私は、だいたいは、1つのスレでは、複数の回答をすることはしないようにしています。今回の場合、もしも、二つの内容が、コンフリクト(ぶつかる）ということがあれば、同時に使えないことがあります。

しかし、時間表示させるマクロが必要でしたら、別におっしゃってください。過去のログを調べれば、私の試行錯誤の内容もありますが、OnTime ではないと思います。いろいろ試した結果では、UserForm に出させるのが、独立して影響を受けず、安定しています。API Timer というものもありますから、もう、イベントを新たに作るようなものです。

>回答者様の回答内容にも知らない言葉があり、知識が無い場合は質問しないほうが良いと痛感しております。

質問しないほうがよいなんてことはありません。分からない時は、お任せでいいと思います。ただし、超ハイレベルのもので出来ないものもありますが、それは、諦めるか別の所で聞くしかありませんね。あまり、知らないことを、あまり自分の中で頑張らないほうがよいというだけです。時々、他人に迷惑を掛けてはいけないとして、自分の中で頑張ろうするあまり、余計におかしなことになってしまう人がいます。

それと、私が書いた、DDEというのは、今回は、どうやら、私の思い違いのようです。そんなものを書くのは、私ぐらいしかいません。世界の掲示板を検索してもヒットしないのですが、それは、誰かが隠しているからだと思います。

Yaoo天気の切り出しマクロを含めて、作ってみましたが、しばらく様子を見させていただきます。
今は、本日の日付の分だけです。

回答No.5

Wendy02

ちょっと割り込ませていただきます。

もう、すでに回答者さんがいらっしゃいますので、最初に書いた方が諦めない限りは、私は、なるべくコードは書かないようにしますが、時間指定で、タスクで動かすというなら、また、別問題です。別の話と二重になっているのかもしれません。

それと、新しい質問を立てていますが、こちらが解決しないままに、同じ質問をしても、常連の人たちで、ここを読んでいる人たちは回答はしないはずです。

うまく行かない理由は、ご質問者さんの周辺状況(どういうように使っているか）を示さないままに質問しているからだと思います。しかし、#3のコードの基本コードが指定時間前に起動されて、動かなかったというなら、おそらく基本的な部分で設定のミスがあるのかもしれませんし、手取り足取りというのは限界があります。

例えば、この種の質問の多くは、RSSなどのツールから、OLEやDDE(外部からのデータインポートの方法）で外部から情報を取り出すという要件が含まれていることが多いです。

今回のように、20秒単位という非常に速い動きのものがあります。ただ、20秒のような速い単位の場合は、他のマクロは動かなくなる可能性が強いですし、逆もまた真です。コンフリクトを起こす可能性もあります。その場合、作り方を変えなくてはなりません。OnTime ではない場合もあります。

「天気」は、「転記」のことだろうけれども、これも、本当に、20秒単位で動かすものでしょうか。もし、そうなら、その「転記」の部分を、きちんと公開してもらわないといけません。

補足

天気は転記ではなく、Yahooの天気のページから天気予報をシートにコピーするマクロです。

20秒ごとにセルに現時刻を表示させる事が出来たので、同じ原理で
一定時刻に（夕方以降でないと天気予報が更新されない為）天気予報を
表示させる事が出来るだろうと思ったものの、行き詰った為質問させていただきました。

＞時間指定で、タスクで動かす
＞RSSなどのツールから、OLEやDDE
＞コンフリク
等回答者様の回答内容にも知らない言葉があり、
知識が無い場合は質問しないほうが良いと痛感しております。

一つの投稿で複数の質問をしている方が、「一つの投稿で一つの質問にしろ」と
お叱りを受けているのを見た為、分けさせていただきました。

大変お見苦しく申し訳ございませんでした。

回答No.4

ki-aaa

こんばんわ。

Sub Auto_Open()　Sub auto_close()は、VBAからファイルを開く閉じるをするときは、実行されません。

その場合はWorkbook_Open　Workbook_BeforeCloseのイベントを使う必要があります。

Application.OnTime　実行時間,　"マクロ" ・・・で、
実行時間に現在より前の時間を指定すると無条件に実行されてしまうみたいです。Sub Auto_Open()に一行追加しました。　

Sub Auto_Open()
TargetTime = Date + TimeValue("21:15")
If Now >= TargetTime Then Exit Sub
WaitTime = TimeValue("00:00:10")
Application.OnTime TargetTime, "天気", WaitTime
End Sub

回答No.3

ki-aaa

こんにちわ、当方では、うまくいっています。

Option Explicit
Dim TargetTime, WaitTime

Sub Auto_Open()
TargetTime = Date + TimeValue("16:30")
WaitTime = TimeValue("00:00:10")
Application.OnTime TargetTime, "天気", WaitTime
End Sub

Sub 天気()
MsgBox "aaaaa"
End Sub

Sub auto_close()
On Error Resume Next
Application.OnTime TargetTime, "天気", , False
On Error GoTo 0
End Sub

お礼

やはり更新が出来ませんでした。

新しくBookを開き、挿入→標準モジュールで
記載していただいたものを貼り付けて時間を変更し、
その時間になっても何も起きませんでした。

ひょっとしてやり方が間違っているのでしょうか？
ＶＢＡ初心者で大変申し訳ございません。

Office Excel 2003 SP2です。宜しくお願い致します。

補足

あたらしいBookでやったら出来ました。

しかし、

Sub 天気()
MsgBox "aaaaa"
End Sub

の部分をもともとの天気マクロに書き換えると出来ませんでした。
天気マクロはWeb上から天候のデータを貼り付けるものです。
相性とかがあるのでしょうか？

Sub 天気()
'
' 天気 Macro

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://weather.yahoo.co.jp/weather/jp/11/4310.html", Destination:=Range( _
"A1"))
.Name = "4310_6"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub

回答No.2

ki-aaa

間違えました。

>targetTime = now + TimeValue("17:00")
↓
targetTime = Date + TimeValue("17:00")

補足

回答ありがとうございました。

変更しましたが上手く動きませんでした。

Sub Auto_Open()
Dim TargetTime, WaitTime
TargetTime = Date + TimeValue("16:12")
WaitTime = TimeValue("00:00:10")
Application.OnTime TargetTime, "天気", WaitTime
End Sub

Sub 天気()
'
' 天気 Macro
'
'ここに天気予報を取得するマクロが記入されています。

End With
End Sub
Sub auto_close()
Dim i As Integer, TargetTime
On Error Resume Next
For i = 1 To 10
TargetTime = Date + TimeValue("16:12")
Application.OnTime TargetTime, "天気", , False
Next i
End Sub