Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6815 / 13644 ツリー ←次へ | 前へ→

【42873】1つにできますか? まーくん 06/9/24(日) 3:34 質問[未読]
【42876】Re:1つにできますか? Kein 06/9/24(日) 13:56 回答[未読]
【42878】Re:1つにできますか? まーくん 06/9/24(日) 16:34 発言[未読]
【42883】Re:1つにできますか? Kein 06/9/24(日) 17:21 発言[未読]
【42899】Re:1つにできますか? まーくん 06/9/25(月) 1:04 発言[未読]
【42908】Re:1つにできますか? まーくん 06/9/25(月) 11:21 発言[未読]
【42961】Re:1つにできますか? まーくん 06/9/28(木) 2:30 発言[未読]

【42873】1つにできますか?
質問  まーくん  - 06/9/24(日) 3:34 -

引用なし
パスワード
   皆さん よろしくお願いします。昨日教えていただいた別々の
コードですが1つにできますか?
下記のように修正してみたのですがうまく表示しません。
Case・・・は表示してくれるのですが
時間で表示が出ません 仮に出来なければ1つのbookに
両方のコードを書き込みたいのですができますか?
別々に標準モジュール1.2に
書き込んだのですがエラーが出てしまいます。下記エラー内容
「名前が適切ではありません Auto_Open」
[#42832] [#42863]
よろしくお願いします。
また[#42863]keinさんのコードですが
シートの保護設定が保護の状態ですと
起動しないようなのですが?いかがでしょうか


Sub Auto_Open()
 Dim lowerbound As Integer
 Dim upperbound As Integer
 Dim MyR As Range
 
 lowerbound = 1
 upperbound = 100

'☆追加
 Randomize  ' 乱数発生ルーチンを初期化します。
 Select Case Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
 Case 1 To 10
  MsgBox "血圧は正常ですか?"
 Case 11 To 20
  MsgBox "今日のあなたの運勢は○吉です"
 Case 21 To 30
  MsgBox "今日もお仕事頑張るぞ!"
 Case 31 To 40
  MsgBox "昨日の夕飯何食べました?"
 Case 41 To 50
  MsgBox "おとといの朝食はなに?
 Case 51 To 60
  MsgBox "今日はいくら稼ぎましたか?"
 Case 61 To 70
  MsgBox "今日は残業無しで帰りましょう。
 Case 71 To 80
  MsgBox "今日のあなたの運勢は○凶です。
 Case 81 To 90
  MsgBox "貴方の名前・年齢・血液型は?
 Case 91 To 100
  MsgBox "お元気ですか・・・?"
  End Select


  Set MyR = Worksheets(1).Range("IV1:IV4")
  With Application
   If .Count(MyR) > 0 Then GoTo ELine
   If IsEmpty(MyR.Cells(1)) And _
   Time < TimeValue("02:48:00") Then
     .OnTime TimeValue("02:48:00"), "MyScd"
     MyR.Cells(1).Value = "02:49:00"
   End If
   If IsEmpty(MyR.Cells(2)) And _
   Time < TimeValue("11:55:00") Then
     .OnTime TimeValue("11:55:00"), "MyScd"
     MyR.Cells(2).Value = "11:56:00"
   End If
   If IsEmpty(MyR.Cells(3)) And _
   Time < TimeValue("15:00:00") Then
     .OnTime TimeValue("15:00:00"), "MyScd"
     MyR.Cells(3).Value = "15:01:00"
   End If
   If IsEmpty(MyR.Cells(4)) And _
   Time < TimeValue("17:00:00") Then
     .OnTime TimeValue("17:00:00"), "MyScd"
     MyR.Cells(4).Value = "17:01:00"
   End If
  End With
ELine:
  Set MyR = Nothing
End Sub

Sub MyScd()
  Dim WshShell As Object

  Set WshShell = CreateObject("WScript.Shell")
  With Worksheets(1)
   If Time < .Range("IV1").Value Then
     WshShell.Popup "休憩時間ですよ", 7, , 64
     .Range("IV1").Clear
   ElseIf Time < .Range("IV2").Value Then
     WshShell.Popup "そろそろ昼食の時間です", 7, , 64
     .Range("IV2").Clear
   ElseIf Time < .Range("IV3").Value Then
     WshShell.Popup "お茶の時間ですよ", 7, , 64
     .Range("IV3").Clear
   ElseIf Time < .Range("IV4").Value Then
     WshShell.Popup "終了時間ですよ", 7, , 64
     .Range("IV4").Clear
   End If
  End With
  Set WshShell = Nothing
End Sub

【42876】Re:1つにできますか?
回答  Kein  - 06/9/24(日) 13:56 -

引用なし
パスワード
   >1つのbookに両方のコードを書き込みたい
Auto_Openというタイトルのプロシージャは、イベントマクロですから
複数を設定することは出来ません。なので原則として今のように、
二つの処理を一つのプロシージャに書くことになります。
>時間で表示が出ません 
OnTimeでスケジュールを設定する条件として、最初に
> If .Count(MyR) > 0 Then GoTo ELine
というコードがありますが、意味は理解してますか ? そこは
「 Worksheets(1).Range("IV1:IV4")で、時刻が一ヶ所でも入力されていたら
ラベルのところへ飛んでOnTimeの設定を中止する」という意味です。
一方、既に設定されたスケジュールが実行されたとき、IV1:IV4のいずれかの
セルの値はクリアされるようにしてあります。4つのスケジュール全てが
実行されたとき、初めて Application.Count(MyR) の戻り値が 0 になって
一日分のスケジュールが再設定されるわけです。その点、先のスレッドにも
"重複設定されないように"と説明しておいたはずですよ。
で、どうしても設定済みのスケジュールを解除して、一から設定し直したいなら

Sub Auto_Open()
  Dim MyR As Range

  Randomize  ' 乱数発生ルーチンを初期化します。
  Select Case Int(100 * Rnd + 1)
   Case 1 To 10: MsgBox "血圧は正常ですか?"
   Case 11 To 20: MsgBox "今日のあなたの運勢は○吉です"
   Case 21 To 30: MsgBox "今日もお仕事頑張るぞ!"
   Case 31 To 40: MsgBox "昨日の夕飯何食べました?"
   Case 41 To 50: MsgBox "おとといの朝食はなに?
   Case 51 To 60: MsgBox "今日はいくら稼ぎましたか?"
   Case 61 To 70: MsgBox "今日は残業無しで帰りましょう。
   Case 71 To 80: MsgBox "今日のあなたの運勢は○凶です。
   Case 81 To 90: MsgBox "貴方の名前・年齢・血液型は?
   Case 91 To 100: MsgBox "お元気ですか・・・?"
  End Select
  With Worksheets(1)
   .Unprotect
   Set MyR = .Range("IV1:IV4")
  End With
  With Application
   If .Count(MyR) > 0 Then GoTo ELine
   If IsEmpty(MyR.Cells(1)) And _
   Time < TimeValue("02:48:00") Then
     .OnTime TimeValue("02:48:00"), "MyScd"
     MyR.Cells(1).Value = "02:49:00"
   End If
   If IsEmpty(MyR.Cells(2)) And _
   Time < TimeValue("11:55:00") Then
     .OnTime TimeValue("11:55:00"), "MyScd"
     MyR.Cells(2).Value = "11:56:00"
   End If
   If IsEmpty(MyR.Cells(3)) And _
   Time < TimeValue("15:00:00") Then
     .OnTime TimeValue("15:00:00"), "MyScd"
     MyR.Cells(3).Value = "15:01:00"
   End If
   If IsEmpty(MyR.Cells(4)) And _
   Time < TimeValue("17:00:00") Then
     .OnTime TimeValue("17:00:00"), "MyScd"
     MyR.Cells(4).Value = "17:01:00"
   End If
  End With
ELine:
  Worksheets(1).Protect: Set MyR = Nothing
End Sub

'↓これを追加

Sub Auto_Close()
  Dim C As Range
  Dim Tm As Date
  Dim Ans As Integer
 
  With Worksheets(1)
   .Unprotect
   If Application.Count(.Range("IV1:IV4")) > 0 Then
     For Each C In .Range("IV1:IV4").SpecialCells(2, 1)
      Tm = DateAdd("n", -1, C.Value)
      Ans = MsgBox(Tm & " のスケジュールは実行されていません" _
      & vbLf & "このまま中止しますか", 36)
      If Ans = 6 Then Application.OnTime Tm, "MyScd", , False
     Next
   End If
   .Protect
  End With
  ThisWorkbook.Save
End Sub

'↓これは変更無し

Sub MyScd()
  Dim WshShell As Object

  Set WshShell = CreateObject("WScript.Shell")
  With Worksheets(1)
   If Time < .Range("IV1").Value Then
     WshShell.Popup "休憩時間ですよ", 7, , 64
     .Range("IV1").Clear
   ElseIf Time < .Range("IV2").Value Then
     WshShell.Popup "そろそろ昼食の時間です", 7, , 64
     .Range("IV2").Clear
   ElseIf Time < .Range("IV3").Value Then
     WshShell.Popup "お茶の時間ですよ", 7, , 64
     .Range("IV3").Clear
   ElseIf Time < .Range("IV4").Value Then
     WshShell.Popup "終了時間ですよ", 7, , 64
     .Range("IV4").Clear
   End If
  End With
  Set WshShell = Nothing
End Sub

よく意味を調べてから使うように。
なお
>TimeValue("02:48:00")
は、24時間制なら午前2時になることを承知してますね ?

【42878】Re:1つにできますか?
発言  まーくん  - 06/9/24(日) 16:34 -

引用なし
パスワード
   ▼Kein さん:
ありがとうございます。
いろいろ時間を変えて試しているのですが
時間がきて"休憩時間ですよ"と表示され
約7秒で消えるはずなのですが消えません。
Protectに関係あるのでしょうか?

>なお
>>TimeValue("02:48:00")
>は、24時間制なら午前2時になることを承知してますね ?
はい上記は検証中の数字でした。

【42883】Re:1つにできますか?
発言  Kein  - 06/9/24(日) 17:21 -

引用なし
パスワード
   >Kein - 06/9/23(土) 17:24
に提示したテストコードだと、うまくいくのでしょーか ?

【42899】Re:1つにできますか?
発言  まーくん  - 06/9/25(月) 1:04 -

引用なし
パスワード
   ▼Kein さん:
>>Kein - 06/9/23(土) 17:24
>に提示したテストコードだと、うまくいくのでしょーか ?

追加報告ですが、テストコードなんですが新規にエクセルを立ち上げ直後に
テストコード専用のbookでためすと表示されて消えるのですが
保護の設定してあるbookで時間が来て表示されたままの状態になります。
ここでOKで保護の設定してあるbookを閉じます。次に

専用のbookを開き実行すると同じように消えなくなります。
かなり動作が微妙な感じです。
上記ちょっとややこしい説明ですがわかりますか?
報告まで

【42908】Re:1つにできますか?
発言  まーくん  - 06/9/25(月) 11:21 -

引用なし
パスワード
   ▼Kein さん:
>>Kein - 06/9/23(土) 17:24
>に提示したテストコードだと、うまくいくのでしょーか ?
さらにいろいろ通常のコードでテストしてみたのですが
AutoOpenでbookを開きセットした1回目で"休憩時間ですよ"が
表示されます当然このときIVの1〜4にデータが入っており
"休憩時間ですよ"を点灯したままのものをOKで消します。
この後×で閉じようとすると
11:55:00のスケジュールは実行されてません。このまま中止しますか
いいえをクリック続いて同じように
15:00:00同上内容で聞かれます同じくいいえをクリック
同17:00:00もいいえをクリックで上書き保存します。これを閉じます。
次に同bookを起動させ手動でMyscd(このときIV2〜4は前のデータ時刻が残ったまま)起動させると表示され消えるんですよね?不思議です

また同上の11:55:00のスケジュールは実行されてません。このまま中止しますかを
はいをクリックすると
実行時エラー1004
OnTimeメゾットは失敗しました'Appplication'オブジェクト
      終了  デバック ヘルプ (各ボタン)で
デバックを押すとコードの
If Ans = 6 Then Application.OnTime Tm,"MyScd", ,False の
Application以降が黄色になっていました
報告です

【42961】Re:1つにできますか?
発言  まーくん  - 06/9/28(木) 2:30 -

引用なし
パスワード
   ▼Kein さん:
相談ですがよろしくお願いします。
>>Kein - 06/9/23(土) 17:24
>に提示したテストコードだと、うまくいくのでしょーか ?
何十通りを想定しテストしましたが不安定です。
別の方法はありませんか?
IVセルを使わない方法とか・・・

6815 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free