[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『点滅とタイマ－の両方のマクロを作動させたい』（みこ）
以前、点滅とタイマ－のマクロを ご教授していただきました。 どちらも、個別に作動してくれるのですが、 両方のコ－ドを入力すると、 タイマ－のみしか作動しないのです。 シ－トを開いたら 両方作動させるには、 どのようにしたらよいのでしょうか? ご教授よろしくお願いします。 まだまだ、マクロは精進中です。
[[20090420091851]] 『指定のセルの点滅停止ボタン』（みこ）
[[20090513133425]] 『タイマ-を表示させたい』（みこ）
両方とも開始から終了までが一つのループ処理になっているので処理が終わらないと、 他のマクロ処理ができるようになっていません。
一つのループの中で、両方の処理を行うようにすることも可能ですが、このような場合 は OnTime メソッドを使用すれば独立した処理として実現できます。
（１）ThisWorkbook モジュールの下に下記を置きます。
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub Workbook_Open()
ActiveSheet.Protect Password:="pass", DrawingObjects:=True, contents:=True, UserInterfaceonly:=True
startTimer
startBlink
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
（２）標準モジュールの下に下記を置きます。 －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Option Explicit
'--- 点滅用大域変数 ---------
Public Const BLINK_CELLS = "A11,G1"
Public Const ON_COLOR = 3
Public Const OFF_COLOR = 2
Public blinkOn As Boolean
Public originalFonts() As Variant
Public objRange As Range
Public nextBTime As Variant
'--- タイマー用大域変数 ---------
Public nextTTime As Variant
Public startTime As Variant
'------------------------------------------------------
Sub startBlink()
'------------------------------------------------------
MsgBox "今日は、" & Day(Now) & "日です。入力する場合は、日付点滅を解除して入力してください。", _
vbInformation, Year(Now) & "年" & Month(Now) & "月"
Set objRange = ActiveSheet.Range(BLINK_CELLS)
ReDim originalFonts(1 To objRange.Count)
Dim r As Range
Dim i As Long
i = 1
For Each r In objRange
originalFonts(i) = r.Font.ColorIndex
i = i + 1
Next
Blink
End Sub
'------------------------------------------------------
Sub stopBlink()
'------------------------------------------------------
On Error Resume Next
Application.OnTime nextBTime, "Blink", , False
On Error GoTo 0
Dim r As Range
Dim i As Long
i = 1
For Each r In objRange
r.Font.ColorIndex = originalFonts(i)
i = i + 1
Next
End Sub
'------------------------------------------------------
Sub Blink()
'------------------------------------------------------
Dim color As Integer
Dim r As Range
If blinkOn = True Then
color = ON_COLOR
blinkOn = False
Else
color = OFF_COLOR
blinkOn = True
End If
For Each r In objRange
r.Font.ColorIndex = color
Next
nextBTime = Now + TimeValue("0:0:01")
Application.OnTime nextBTime, "Blink"
End Sub
'------------------------------------------------------
Sub startTimer()
'------------------------------------------------------
startTime = Now
printTimer
End Sub
'------------------------------------------------------
Sub stopTimer()
'------------------------------------------------------
On Error Resume Next
Application.OnTime nextTTime, "printTimer", , False
On Error GoTo 0
End Sub
'------------------------------------------------------
Sub printTimer()
'------------------------------------------------------
.TextBoxes("w_text").Text = Format(Now - startTime, "h:mm:ss")
nextTTime = Now + TimeValue("0:0:01")
Application.OnTime nextTTime, "printTimer"
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
（３）Sheetモジュールの下に下記を置きます。
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub CommandButton1_Click()
stopBlink
End Sub
Private Sub CommandButton2_Click()
stopTimer
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
ボタンの名前や表示対象は適宜変更してください。 (Mook)
このようなコードを記述しても、 >タイマ－のみしか作動しないのです。 というコードを記述して下さい。そうしないとこのような掲示板の意味が半減してしまいますよ！！
新規ブックにて試してみてください。
標準モジュール(Module1）に
'=================================================================
Sub 準備()
Dim r As Range
With Worksheets("sheet1")
Set r = .Range("l2:m3")
With .Buttons.Add(r.Left, r.Top, r.Width, r.Height)
.Caption = "停止"
.OnAction = "stop_tenmetu"
End With
With .TextBoxes.Add([d1].Left, [d1].Top, [d1].Width, [d1].Height)
.Name = "w_text"
.HorizontalAlignment = xlRight
.LockedText = False
End With
.Range("a11,g1").Value = "ichinose"
End With
Set r = Nothing
End Sub
まず上記の「準備」を実行してください。
Sheet1に 停止用ボタンと時刻表示用のテキストボックスが作成されます（点滅対象は、A11とg1です）
上記の準備を実行した後に別の標準モジュール（Module2）に 点滅を管理するプロシジャー群
'=============================================================================
Option Explicit
Private t_selr As Range
Private t_cid(1 To 2) As Long
Private t_scid() As Long
Sub tenmetu_init(ByVal rng As Range, ByVal col1 As Long, ByVal col2 As Long) '点滅準備処理
Dim crng As Range
Dim g0 As Long
Set t_selr = rng '点滅させるセル範囲
t_cid(1) = col1 '点滅色
t_cid(2) = col2 ' 〃
ReDim t_scid(1 To t_selr.Count)
g0 = 1
For Each crng In t_selr
t_scid(g0) = crng.Font.ColorIndex
g0 = g0 + 1
Next
t_selr.Font.ColorIndex = t_cid(1)
End Sub
'=============================================================================
Sub tenmetu_exe() '点滅実行
With t_selr.Font
.ColorIndex = .ColorIndex Xor (t_cid(1) Xor t_cid(2))
End With
End Sub
'=============================================================================
Sub tenmetu_term() '点滅終了処理
Dim g0 As Long
Dim crng As Range
g0 = 1
For Each crng In t_selr
crng.Font.ColorIndex = t_scid(g0)
g0 = g0 + 1
Next
Set t_selr = Nothing
Erase t_cid()
Erase t_scid()
End Sub
別の標準モジュール（Module3）に点滅と時刻表示を行ったり、停止したりするプロシジャー
Option Explicit
'===========================================================================
Private stop_mv As Boolean
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub tenmetu_and_time()
Dim nw As Date
ActiveSheet.Protect Password:="pass", DrawingObjects:=True, _
contents:=True, UserInterfaceonly:=True
MsgBox "今日は、" & Day(Now) & "日です。入力する場合は、日付点滅を解除して入力してください。", _
vbInformation, Year(Now) & "年" & Month(Now) & "月"
Call tenmetu_init(Range("a11,g1"), 3, 2)
stop_mv = False
nw = Now()
With ActiveSheet
Do Until stop_mv
Call tenmetu_exe
DoEvents
.TextBoxes("w_text").Text = Format(Now() - nw, "h:mm:ss")
Sleep 100
DoEvents
Loop
End With
Call tenmetu_term
End Sub
'==================================================================
Sub stop_tenmetu()
stop_mv = True
End Sub
最後にThisworkbookのモジュールにシートがアクティブになったときのイベント
Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh Is Worksheets("sheet1") Then tenmetu_and_time
End Sub
'==================================================================
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
If Wn.ActiveSheet Is Worksheets("sheet1") Then tenmetu_and_time
End Sub
一度保存して閉じた後、再度開いて確認してください。
ichinose
回答ありがとうございました。
Mook様、
Sub printTimer()
'------------------------------------------------------
.TextBoxes("w_text").Text = Format(Now - startTime, "h:mm:ss")
nextTTime = Now + TimeValue("0:0:01")
Application.OnTime nextTTime, "printTimer"
End Sub
エラ－表示がでるのですが..
ichinose様、
>というコードを記述して下さい。
最初はコードを記述したのですが、
未読表示が付かなかったものですから、
このような形文になってしまい申し訳ありません。
ichinose様、いつもながら 解りやすい回答をいただき
感銘しています。
出来ました。
更に質問なのですが
点滅とタイマ－の停止ボタンを
別々にすることは可能なのでしょうか?
そして、
Columns("I:I").ColumnWidth = 0
Columns("L:L").ColumnWidth = 0
このコ－ドは、
どこにいれたらよいのでしょうか?
もう一点、
点滅の速度のコ－ドってあるのでしょうか?
よろしくお願いします。
(みこ)
前のソースをコピーしただけなので、不備があったようです。
Worksheets("Shhet1").TextBoxes("w_text").Text = Format(Now - startTime, "h:mm:ss")
にしてください（w_text というテキストボックスがある前提ですが）。
(Mook)
では、改めて新規ブック（Sheet1というシート名が存在する）にて試してください。
標準モジュール（Module1）に
'========================================================================
Sub 準備()
Dim r As Range
With ActiveSheet
Set r = .Range("n2:o3")
With .Buttons.Add(r.Left, r.Top, r.Width, r.Height)
.Caption = "点滅停止"
.OnAction = "stop_tenmetu"
End With
Set r = .Range("n5:o6")
With .Buttons.Add(r.Left, r.Top, r.Width, r.Height)
.Caption = "タイマー停止"
.OnAction = "stop_watch"
End With
With .TextBoxes.Add([d1].Left, [d1].Top, [d1].Width, [d1].Height)
.Name = "w_text"
.HorizontalAlignment = xlRight
.LockedText = False
End With
.Range("a11,g1").Value = "ichinose"
.Columns("i:i").Hidden = True
.Columns("L:L").Hidden = True
End With
Set r = Nothing
End Sub
まず上記の「準備」を実行してください。
Sheet1に 点滅停止用ボタンとタイマー停止用ボタンと時刻表示用のテキストボックスが作成されます （点滅対象は、A11とg1です）。又、
Columns("I:I").ColumnWidth = 0
Columns("L:L").ColumnWidth = 0
これと同類コードは、準備に入れました。（シートの体裁を整えるコードだと解釈しました）
上記の準備を実行した後に別の標準モジュール（Module2）に 点滅を管理するプロシジャー群
'==================================================================================
Option Explicit
Private t_selr As Range
Private t_cid(1 To 2) As Long
Private t_scid() As Long
'==================================================================================
Sub tenmetu_init(ByVal rng As Range, ByVal col1 As Long, ByVal col2 As Long) '点滅準備処理
Dim crng As Range
Dim g0 As Long
Set t_selr = rng '点滅させるセル範囲
t_cid(1) = col1 '点滅色
t_cid(2) = col2 ' 〃
ReDim t_scid(1 To t_selr.Count)
g0 = 1
For Each crng In t_selr
t_scid(g0) = crng.Font.ColorIndex
g0 = g0 + 1
Next
t_selr.Font.ColorIndex = t_cid(1)
End Sub
'==================================================================================
Sub tenmetu_exe() '点滅実行
With t_selr.Font
.ColorIndex = .ColorIndex Xor (t_cid(1) Xor t_cid(2))
End With
End Sub
'==================================================================================
Sub tenmetu_term() '点滅終了処理
Dim g0 As Long
Dim crng As Range
On Error Resume Next
g0 = 1
For Each crng In t_selr
crng.Font.ColorIndex = t_scid(g0)
g0 = g0 + 1
Next
Set t_selr = Nothing
Erase t_cid()
Erase t_scid()
On Error GoTo 0
End Sub
別の標準モジュール（Module3）に点滅と時刻表示を行ったり、それぞれを停止したりするプロシジャー
'==========================================================================
Option Explicit
'===========================================================================
Private loop_tmt As Boolean
Private loop_wth As Boolean
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub chk_and_start()
If loop_tmt = False And loop_wth = False Then
tenmetu_and_time
ElseIf loop_tmt = False Then
loop_tmt = True
ElseIf loop_wth = False Then
loop_wth = True
End If
End Sub
'===================================================================================
Sub tenmetu_and_time()
Dim nw As Date
Dim f_false As Long
ActiveSheet.Protect Password:="pass", DrawingObjects:=True, _
contents:=True, UserInterfaceonly:=True
MsgBox "今日は、" & Day(Now) & "日です。入力する場合は、日付点滅を解除して入力してください。", _
vbInformation, Year(Now) & "年" & Month(Now) & "月"
Call tenmetu_init(Range("a11,g1"), 3, 2)
loop_tmt = True
loop_wth = True
nw = Now()
With ActiveSheet
Do Until loop_tmt = False And loop_wth = False '変更
If loop_tmt Then
If f_false = 1 Then
Call tenmetu_init(Range("a11,g1"), 3, 2)
End If
f_false = 0
Call tenmetu_exe
Else
If f_false = 0 Then
Call tenmetu_term
f_false = 1
End If
End If
DoEvents
If loop_wth Then .TextBoxes("w_text").Text = Format(Now() - nw, "h:mm:ss")
Sleep 400
' ↑この400を100～500の間で変更してみてください。値が少ないほど点滅が速くなります
DoEvents
Loop
End With
Call tenmetu_term
End Sub
'==================================================================
Sub stop_tenmetu()
loop_tmt = False
End Sub
'==================================================================
Sub stop_watch()
loop_wth = False
End Sub
最後にThisworkbookのモジュールにシートがアクティブになったときのイベント
'=================================================================
Option Explicit
'=================================================================
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh Is Worksheets("sheet1") Then Call chk_and_start
End Sub
'==================================================================
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
If Wn.ActiveSheet Is Worksheets("sheet1") Then Call chk_and_start
End Sub
一度保存して閉じた後、再度開いて確認してください。
ichinose
まぁこのレベルのプログラムでしたら、どのような方法でも動けばよいのだと思いますが、 OnTime は1秒単位でしか制御できません。 なので、これより細かい精度では処理できませんが、これを使用する利点はいくつもの 処理を独立して設定できるという点（処理の追加や削除が簡単）と、処理を占有しません ので、これを実行している間も他のマクロ処理を実行できるという点です。
他にマクロの処理する必要がなく、１秒以下の制御をしたいということであれば、 ichinose さんのを使用されるとよいかと思います。 (Mook)
助言ありがとうございました。
ichinose様、
思い通りに出来ました。
詳しく説明して下さって、
嬉しく思っています。
更に閉じる列を増やして記述する場合、
例えばJ列を増やしたい
標準モジュール（Module1）の
.Range("a11,g1").Value = "ichinose"
.Columns("i:i").Hidden = True
.Columns("L:L").Hidden = True
End With
Set r = Nothing
End Sub
↓
.Range("a11,g1").Value = "ichinose"
.Columns("i:i").Hidden = True
.Columns("L:L").Hidden = True
.Columns("J:J").Hidden = True ←
End With
Set r = Nothing
End Sub
作動させましたが、動作してくれません。
そこで、
標準モジュール（Module1）の
.Range("a11,g1").Value = "ichinose"
←削除
End With
Set r = Nothing
End Sub
標準モジュール（Module3）の
Sub tenmetu_and_time()
Dim nw As Date
Dim f_false As Long
ActiveSheet.Protect Password:="pass", DrawingObjects:=True, _
contents:=True, UserInterfaceonly:=True
↓
Sub tenmetu_and_time()
Columns("I:I").ColumnWidth = 0 ←
Columns("L:L").ColumnWidth = 0 ←
Columns("J:J").ColumnWidth = 0 ←
Dim nw As Date
Dim f_false As Long
ActiveSheet.Protect Password:="pass", DrawingObjects:=True, _
contents:=True, UserInterfaceonly:=True
に入れてみました。
動作しました。
問題はないですよね。
ichinose様、Mook様
まだまだ
未熟な私ですが、
今後とも
ご指導宜しくお願いします。
(みこ)
解決されたみたいですが・・・、
Columns("I:I").ColumnWidth = 0 ←
Columns("L:L").ColumnWidth = 0 ←
Columns("J:J").ColumnWidth = 0 ←
これらのコードをどのような事情で追加したいのか？ の説明がないのではっきり どこに挿入すればよい とは言えないのです。
私は、最初のシートレイオウトをそのようにしたいのであろう と予想して準備というプロシジャーに 入れました。ここは、シートに初期設定を行うプロシジャーですから、一度実行すれば、 基本的にはその後は 実行されるフローにはなっていません。
tenmetu_and_timeに挿入したとの事ですが、隠した列は、再表示される可能性があるのなら、ここでよいですね！！
>まぁこのレベルのプログラムでしたら
私は、今回の 「このレベルのプログラム」で 四苦八苦していました。
この事例ような繰り返し処理では、Excelのキャパシティとの調整が大変なんです。
私も繰り返しのインターバルが5分とか10分なら、さほど迷わずにOntimeメソッドを選択したと思います。 今回の場合、単独仕様の場合から考慮すると・・・、
１ 点滅
１秒以内の繰り返し処理を想像したため、どうしようか？ ここで悩みました。 取りあえず、長い時間の点滅ではないのだろうと勝手に予測し、ループ処理で行うことを決めました。 この時点では、Ontimeという方法も捨てきれないなあ という思いを残しながら決断です。
２ タイマー この仕様では、割と簡単にループ処理で行くことを決定。 一つは、長い時間の処理ではないのだろうという予想と秒以下の場合（拡張された場合） の対処も簡単そうという理由です。
今回は、上記の理由でループで処理しました。
ループという手法を使うと処理を独占という問題にぶつかります。 これが、Excelの限界なのです。但し、今回のループ処理でも Doevent とSleep（API）の使用でCPUの占有率を下げています (これがSleepでないと駄目なんです。application.waitでは、占有率は下がらない） 更にブックの既存イベントをトリガーにループ処理が開始されていますから、 他のマクロの実行も可能にしています。というより、そのための上記の施しなのですから・・・。
が、それでも不安定感は否めません。これが取り除かれれば、ループ処理で監視した 独自イベントが実務でも使えますが、まだその決心がついていません。
今回の仕様でループ処理にしたもう一つの理由は、ループでの監視というアルゴリズムで どれだけ通用するかを質問者さんに試していただきたかったからです。 この結果は、もう少し時間が経たなければ出てこないかもしれません。
ichinose
貴重な時間をさいて下さって、
感謝しています。
新しい予定表を作成している段階で、
まだまだ、隠した列は出てくると思います。
>隠した列は、再表示される可能性があるのなら、ここでよいですね！！
回答ありがとうございます。
ichinose様、
新しい予定表の完成まで
まだまだ
時間がかかりますが
運用出来たあかっきには、
報告させていただきます。
ichinose様、
本当に
ありがとうございました。
(みこ)
リンクを修正しました（kazu） 2009/08/04
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.