VBAでセルごとにタイマーを使用できますか？

質問

ＶＢＡ初心者のものです。が・・・

'B4に値が入ったら30分後にB4の値をB5に移動する。
'対象セルはB4～AZ4までで、セルごとに30分後に値を一段下移動する。
とういうようなマクロを作りたいのですが、

タイマーはシート単位になるのでしょうか？

現在はダブルクリックイベントにてセルの値を下げています。

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)

Application.ScreenUpdating = False

If Intersect(target, Range("b4:zz4")) Is Nothing Then Exit Sub

Call 移動

End Sub
Sub 移動()
Dim c As Range
Set c = ActiveCell ' 使用されている

c.Select

Selection.Cut

c.Offset(1, 0).Select

ActiveSheet.Paste

End Sub

対象セルがたくさんあるので、なんとか自動処理できないものでしょうか？

回答No.6

tom04 · ベストアンサー

続けてお邪魔します。

＞私よりも、エクセルを知らない人が使うためなんです。（工場の工程管理表です。）
＞出来るだけ、操作ミスを少なくする為なんです

というコトはChangeイベントが一番良い！というコトですね。
それでは今回は4行目にコピー＆ペーストした時点でEnterを押さなくて良い方法にしてみました。
（貼り付けた時点で一つ下のセルを選択するようにしています）
Sheet1のコードを↓に変更してみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B4:Z4")) Is Nothing Or Target.Count > 1 Then Exit Sub
If Target <> "" Then
'▼ココから追加
Application.CutCopyMode = False
Target.Offset(1).Select
'▲2行追加
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1) = Target.Address(False, False)
Application.OnTime earliesttime:=Now() + TimeValue("0:30:00"), procedure:="セル移動"
End If
End Sub

※　標準モジュールは前回のままでOKです。
※　No.2で書いたように「ThisWorkbook」のコードはやはり必要かもしれませんね。m(_ _)m

お礼

本日、要約、パソコンに向かうことが出来ました。私も一作業員なので、なかなか画面とにらめっこできる時間がありませんでした。早速、最終的なマクロを実行してみました。動作的に上手く行きました。ありがとうございます。このマクロをまた自分なりにアレンジしていきたいと思います。また、行き詰ったらご指導のほど、宜しくお願い申し上げます。

回答No.9

mt2008

> ４行目のデータが５行目に移動した後に、５行目に移動したデータがなくなってしまいます。

4行目から５行目にデータを移動しますから、元々５行目に何かデータが有った場合は上書きしています。ANo.4の補足を見てそのような仕様だと思ったのですが、違いますか？

お礼

なんとかご指摘いただいた内容、およびサンプルのマクロで作り上げることが出来ました。
まだまだ初心者なので、自分でも勉強し頑張りたいと思います。このたびは忙しい中、誠にありがとうございました。

回答No.8

mt2008

(1).Sampleにミスとデバッグ用に次回実行時刻をA2に表示させっぱなしになっていたので修正しました。これで如何でしょう（Worksheetモジュールの方はそのまま使って下さい）。
(2).前回処理時刻をどこかに記憶したうえで内部の判断処理を変更すれば消す必要ありませんが、とりあえずパスさせてください。
(3).Sampleは一度実行するとブックを閉じるか、A1に1と入れない限り1分周期で実行されます。

Sub Sample()
　　Dim dMytime As Date
　　If ThisWorkbook.Worksheets("Sheet1").Range("A1") = 1 Then Exit Sub
　　Application.EnableEvents = False
　　For Each c In ThisWorkbook.Worksheets("Sheet1").Range("B4:AZ4").Cells
　　　　If (c.Offset(-3, 0).Value > 0) * (c.Offset(-3, 0) <= Now()) Then
　　　　　　c.Offset(-3, 0).Value = ""
　　　　　　c.Offset(1, 0).Value = c.Value
　　　　　　c.Value = ""
　　　　End If
　　Next
　　Application.EnableEvents = True
　　dMytime = DateAdd("n", 1, Now())
　　Application.OnTime dMytime, "Sample", dMytime + TimeValue("0:00:10")
End Sub

補足

おはようございます。サンプルマクロの二回目、実行してみました。
４行目のデータが５行目に移動した後に、５行目に移動したデータがなくなってしまいます。
マクロのどこを修正すればよろしいのでしょうか？お手数お掛けいたしますが、宜しくお願い申し上げます。

回答No.7

mt2008

ANo.1です。

あぁ、他にもマクロがあるんですね。Sampleが動くタイミングでそのマクロが丁度動いていたのかもしれません。
その対策として他のマクロが動いていた場合10秒待つようにしました。また、複数セルがペースト等で同時に更新された場合の対策も盛り込んでみました。

対象シート(例：Sheet1）のモジュール---
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim rTarget As Range
　　Set rTarget = Intersect(Target, Range("B4:AZ4"))
　　If rTarget Is Nothing Then Exit Sub
　　rTarget.Offset(-3, 0).Value = DateAdd("n", 30, Now())
End Sub

標準モジュール----
Sub Sample()
　　Dim dMytime As Date
　　If ThisWorkbook.Worksheets("Sheet1").Range("A1") = 1 Then Exit Sub
　　Application.EnableEvents = False
　　For Each c In ThisWorkbook.Worksheets("Sheet1").Range("B4:AZ4").Cells
　　　　If IsNumeric(c.Offset(-3, 0).Value) * (c.Offset(-3, 0) <= Now()) Then
　　　　　　c.Offset(-3, 0).Value = ""
　　　　　　c.Offset(1, 0).Value = c.Value
　　　　　　c.Value = ""
　　　　End If
　　Next
　　Application.EnableEvents = True
　　dMytime = DateAdd("n", 1, Now())
　　Range("A2") = dMytime
　　Application.OnTime dMytime, "Sample", dMytime + TimeValue("0:00:10")
End Sub

補足

月、火と工場作業でパソコン画面に向かうことが出来ませんでした。
早速お作りいただいたマクロを実行してみました。
Ｂ4にデータを入れ、サンプルマクロを実行→Ｂ5にデータ移動終了。
Ｃ4にデータをいれ、サンプルマクロを実行→Ｃ5にデータ移動終了しましたが、

(1)最初に実行した、Ｂ5のデータが無くなってしまいます。Ｂ5：ＡＺ5のデータは作業の完了結果として、
残したいのですが・・・

(2)Ｂ1からＡＺ1に入る時間は残るように出来ますか？

(3)サンプルマクロをファイルを閉じるまで、絶えず自動実行させることは可能でしょうか？

お仕事中申し訳ありませんが、宜しくお願い申し上げます。

回答No.5

tom04

No.2・4です。

＞B4からAZ4まで、そこに入る値はB10からAZ10に控えております。
B4に値が入ったら30分後にB5に移動して終了。という感じにAZまで。変化させたいのは、4行目と5行目で、10行目は固定。
4行目は作業開始した内容が入り、5行目は作業が完了したという意味で、4行目の内容を移動して表現したいのです

結局Sheet1の4行目データをある時間後に1行下に移動し、4行目セルは何も空白のままでよい！
というコトでしょうか？
そうであればChangeイベントが使えます。
今回もSheet2を作業用のSheetとしています。

↓のコードをSheet1のSheetモジュールに

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B4:Z4")) Is Nothing Or Target.Count > 1 Then Exit Sub
If Target <> "" Then
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1) = Target.Address(False, False)
Application.OnTime earliesttime:=Now() + TimeValue("0:30:00"), procedure:="セル移動"
End If
End Sub

↓のコードを標準モジュールのコードにしてみてください。

Sub セル移動()
Dim str As String, wS As Worksheet
Set wS = Worksheets("Sheet2")
If wS.Range("A2") <> "" Then
str = wS.Range("A2")
With Worksheets("Sheet1").Range(str)
.Offset(1).Delete shift:=xlUp
.Insert shift:=xlDown
.Copy
.Offset(-1).PasteSpecial Paste:=xlPasteFormats
End With
wS.Range("A2").Delete shift:=xlUp
End If
End Sub

※　気になる点として・・・
＞そこに入る値はB10からAZ10に控えております。
の部分がどうしても引っかかるのですが、
10行目データを4行目にコピー＆ペーストする！という意味であれば
もちろんコピー＆ペーストでも構いません。
4行目データが直接入力の場合は問題ないと思いますが、
コピー＆ペーストの場合、
ペースト（貼り付け）た時点でChangeイベントが発生し、Enterを押下してしまうと再びChangeイベントが発生しますので、
ダブって操作することになります。
コピー＆ペーストで4行目データを入力する場合はマウスで別セルを選択するようにしてください。

また、10行目データを「一定時間のち」に4行目に表示したい！
というコトであれば、前回書いたようにChangeイベントでは無限ループに陥ってしまいますので、
No.2のような方法にする必要があると思います。m(_ _)m

補足

4行目のデータが５行目に移動後は４行目はブランクになります。
10行目のデータはコピペです。
元々、10行目のデータ移動は、右クリックイベントで、4行目にコピペしてまして。
4行目から、5行目のデータ移動は作業を省く（簡素化）ために、自動化したいのです。このファイルを使用するのは、私よりも、エクセルを知らない人が使うためなんです。（工場の工程管理表です。）
出来るだけ、操作ミスを少なくする為なんです。

回答No.4

tom04

No.2です。

＞Ｂ4～ＡＺ4までは、ランダムに値が入っていきます。それとＢ4～ＡＺの4に入る値はＢ10～ＡＺ10に固定しております。挿入すると値の一覧が下がってしまうので、カットして貼り付けがしたいのです

すなわち
（1）4行目～10行目までの操作として、11行目以降は変化しないようにしたい！
（2）なおかつ、4行目にはその列の10行目データを持ってきたい！
というコトですね？

前回のコードはChangeイベントにしていましたので、
4行目のデータ変更があるたびにマクロが実行され、無限ループに陥ってしまいます。
そこで苦肉の策ですが、ダブルクリックのイベントにしてみました。
4行目にデータ入力後そのセルをダブルクリックしてみてください。
今回もSheet2を作業用のSheetとして使っています。

↓のコードをSheet1のシートモジュールにコピー＆ペースト

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rC As Long
If Intersect(Target, Range("B4:Z4")) Is Nothing Then Exit Sub
Cancel = True
rC = MsgBox("30分後に" & Left(Target.Address(False, False), 1) & "列の操作を行いますか？", vbYesNo + vbQuestion)
If rC = vbYes Then
With Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = Target.Address(False, False)
Target.Offset(6).Copy
.Offset(, 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
End With
Application.OnTime EarliestTime:=Now() + TimeValue("0:30:00"), procedure:="セルコピー"
Else
Exit Sub
End If
End Sub

次に↓のコードを標準モジュールに

Sub セルコピー()
Dim str As String, wS As Worksheet, myVal
Set wS = Worksheets("Sheet2")
If wS.Range("A2") <> "" Then
str = wS.Range("A2")
myVal = wS.Range("B2")
wS.Range("A2:B2").Delete shift:=xlUp
With Worksheets("Sheet1").Range(str)
.Insert shift:=xlDown
.Offset(6).Delete shift:=xlUp
.Offset(-1) = myVal
.Copy
.Offset(-1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
End If
End Sub

これでSheet1の4行目セルをダブルクリックすると指定時間後にマクロが実行されるはずです。

尚、質問通り「30分後」にマクロを実行する場合、まだ実行されていないマクロがある状態で
ファイルを閉じるコトがあると思いますので、
VBE画面の「ThisWorkbook」をダブルクリックし、↓のコードを追加しておいてください。
（作業用Sheet、Sheet2のデータを消去してBookを閉じます）

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Worksheets("Sheet2").Range("A:B").Clear
End Sub

今度はどうでしょうか？m(_ _)m

補足

土曜日で、多分お休みのところ、お手数お掛け致しまして、誠に申し訳ありません。感謝致します。
早速ですが、
B4からAZ4まで、そこに入る値はB10からAZ10に控えております。
B4に値が入ったら30分後にB5に移動して終了。という感じにAZまで。変化させたいのは、4行目と5行目で、10行目は固定。
4行目は作業開始した内容が入り、5行目は作業が完了したという意味で、4行目の内容を移動して表現したいのです。

文面が足らなくてすみません、お手数お掛け致します。
なお、vbaは会社のパソコンで作ってますので、御指摘頂けます内容の実行は、月曜になりますがよろしくお願い申し上げます。

回答No.3

mt2008

ANO.1です。
補足拝見しました。

> サンプルマクロを実行して、しばらくすると、マクロが実行出来ない、もしくはマクロが無効になっていますと、メッセージが出ます。

Sampleは標準モジュールに入っていますか？
Excelのバージョンも念のために教えてください。

> 補足としてですが、4列目に入る内容が10列目に控えておりますので、10列目は固定したいのです。

4列目＝D列、10列目＝J列　で良いですか？
それとも行と列を間違えているだけでしょうか。

補足

サンプルは標準モジュールに入れております。Excelは2010です。
すいません、行と列を間違えてました。
各B4から右に、AZ4まで、ランダムで値が入って行きます。
値はB10からAZ10に固定しております。
会社のパソコンで、このvbaを作ってますので、新たな御指摘頂けましたら、月曜に実行致します。

回答No.2

tom04

こんばんは！
すでに回答は出ていますので、参考程度で・・・
Sheet1が操作したいSheetとします。

Sheet2を作業用のSheetとして使用していますので、Sheet2は使っていない状態にしておいてください。
まず↓のコードを標準モジュールにコピー＆ペースト

Sub 行挿入()
Dim str As String, wS As Worksheet
Set wS = Worksheets("Sheet2")
If wS.Range("A2") <> "" Then
str = wS.Range("A2")
With Worksheets("Sheet1") '★「Sheet1」は実際のSheet名に！
.Range(str).Insert shift:=xlDown
.Range(str).Offset(1).Copy
.Range(str).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
wS.Range("A2").Delete shift:=xlUp
End If
End Sub

次にSheet1のシートモジュールに↓のコードをコピー＆ペーストしてみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B4:Z4")) Is Nothing Or Target.Count > 1 Then Exit Sub
If Target <> "" Then
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1) = Target.Address(False, False)
Application.OnTime EarliestTime:=Now() + TimeValue("0:30:00"), procedure:="行挿入"
End If
End Sub

※　標準モジュールで「行挿入」した後に元の書式をそのまま残す（下へ移動したセルの書式をそのままコピー＆ペースト）
しています。

単に「値」だけで良い場合は、標準モジュール内の
＞With Worksheets("Sheet1") '★「Sheet1」は実際のSheet名に！
＞.Range(str).Insert shift:=xlDown
＞.Range(str).Offset(1).Copy
＞.Range(str).PasteSpecial Paste:=xlPasteFormats
＞Application.CutCopyMode = False
＞End With
の6行を
＞Worksheets("Sheet1").Range(str).Insert shift:=xlDown
だけにしてください。m(_ _)m

補足

お忙しいところ私の質問に時間を割いていただきありがとうございます。
早速、貴方のマクロを貼り付け、実行してみました。が、値を貼りつけ、マクロを実行すると、30分後に5行目に値が下がらず、マクロ実行したとたんに5行目に値が下がります。
Ｂ4～ＡＺ4までは、ランダムに値が入っていきます。それとＢ4～ＡＺの4に入る値はＢ10～ＡＺ10に固定しております。挿入すると値の一覧が下がってしまうので、カットして貼り付けがしたいのです。

回答No.1

mt2008

こんな感じでどうでしょう？
B1:AZ1を各列の更新予定日時を入れる作業セルとして使用し、B4:AZ4のセルを更新すると更新した日時の30分後の日時が1行目に入ります。

Sampleマクロを実行すると、1分周期で作業セルを見に行き、更新予定時刻を過ぎている列の4行目にセルを1つ挿入し、下方向にシフトしています。
また、一度Sampleマクロを実行すると、ずっと1分周期で処理を行うので、定周期処理を止めたい場合はA1セルに1と入れてください。

ただ、ずっとブックを開きっぱなしであることが条件です。

対象シート(例：Sheet1）のモジュール---
Private Sub Worksheet_Change(ByVal Target As Range)
　　If Intersect(Target, Range("B4:AZ4")) Is Nothing Then Exit Sub
　　Target.Offset(-3, 0).Value = DateAdd("n", 30, Now())　'ここの30が30分後の意味。
End Sub

標準モジュール-----
Sub Sample()
　　If Worksheets("Sheet1").Range("A1") = 1 Then Exit Sub
　　Application.EnableEvents = False
　　For Each c In Worksheets("Sheet1").Range("B4:AZ4").Cells
　　　　If IsDate(c.Offset(-3, 0).Value) * (c.Offset(-3, 0) <= Now()) Then
　　　　　　c.Offset(-3, 0).Value = ""
　　　　　　c.Insert Shift:=xlDown
　　　　End If
　　Next
　　Application.EnableEvents = True
　　Application.OnTime DateAdd("n", 1, Now()), "Sample"
End Sub

補足

お忙しい中、私の質問に救済していただきありがとうございます。
早速、試してみましたが、予定時間を過ぎても、Ｂ4に入った値が、Ｂ5に移動することはありませんでした。
サンプルマクロを実行して、しばらくすると、マクロが実行出来ない、もしくはマクロが無効になっていますと、メッセージが出ます。何が原因なのでしょうか？サンプルマクロを実行している途中で各Ｂ4～ランダムに
値を入れてテストしているのが原因でしょうか？
30分では長いので、2分後でテストしています。

補足としてですが、4列目に入る内容が10列目に控えておりますので、10列目は固定したいのです。