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

Question

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

'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

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

tom04 · Accepted Answer

続けてお邪魔します。

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

というコトは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

mt2008 · Answer

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

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

mt2008 · Answer

(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

mt2008 · Answer

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

tom04 · Answer

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

tom04 · Answer

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

mt2008 · Answer

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

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

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

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

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

tom04 · Answer

こんばんは！すでに回答は出ていますので、参考程度で・・・ 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

mt2008 · Answer

こんな感じでどうでしょう？
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

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

続けてお邪魔します。

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

(1).Sampleにミスとデバッグ用に次回実行時刻をA2に表示させっぱなしになっていたので修正しました。

この回答への補足

ANo.1です。

この回答への補足

No.2・4です。

この回答への補足

No.2です。

この回答への補足

ANO.1です。

この回答への補足

こんばんは！

この回答への補足

こんな感じでどうでしょう？

この回答への補足

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング