マクロ実行中のセル入力について
- 評価
- クリップ 3
- VIEW 5,571
excelvbaでマクロ実行中に
セルに入力をするとマクロがとまってしまいます。
マクロの内容としては、セルの順番にアクティベートにして、
そのセルに入力を出来るようにしたいと思っています。
入力する時間を10秒間作るために、ループを下記のように書いております。
dblTimer = Timer
Do Until Int(Timer - dblTimer) = 11
this_sheet.Cells(2, 6) = Int((Timer - dblTimer))
DoEvents
Loop
11秒になった時にループを抜ける実装にしています。
この時に、セルに入力をするとマクロがとまってしまいます。
エラーメッセージは、
”実行時エラー1004”(アプリケーション定義またはオブジェクト定義のエラーです)
になります。
ネットで色々調べましたが、分かりませんでした。
お分かりになる方いらっしゃいましたら、教えて頂けると大変ありがたいです。
私としては、
宜しくお願い致します。
下記、全体のコードです。
'''lang-excelvba
Sub test_マトリクス順次入力()
ReDim Files_1(0)
ReDim Files_2(0)
Dim this_book As Workbook
Dim this_sheet As Worksheet
Set this_book = Workbooks("自動マクロトレーニング.xlsm")
Set this_sheet = this_book.Worksheets("マトリクス順次入力")
Dim i As Long
i = 3
Do Until Cells(i, 3) = ""
n = UBound(Files_1)
ReDim Preserve Files_1(n + 1)
Files_1(n + 1) = Cells(i, 3)
i = i + 1
Loop
Dim j As Long
j = 3
Do Until Cells(j, 4) = ""
m = UBound(Files_2)
ReDim Preserve Files_2(m + 1)
Files_2(m + 1) = Cells(j, 4)
j = j + 1
Loop
For k = 1 To UBound(Files_1)
this_sheet.Cells(k + 2, 6) = Files_1(k)
Next
For l = 1 To UBound(Files_2)
this_sheet.Cells(2, 6 + l) = Files_2(l)
Next
For k = 1 To UBound(Files_1)
For l = 1 To UBound(Files_2)
this_sheet.Cells(2 + k, 6 + l).Activate
dblTimer = Timer
Do Until Int(Timer - dblTimer) = 11
this_sheet.Cells(2, 6) = Int((Timer - dblTimer))
DoEvents
Loop
Next
Next
End Sub
'''
-
気になる質問をクリップする
クリップした質問は、後からいつでもマイページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
クリップを取り消します
-
良い質問の評価を上げる
以下のような質問は評価を上げましょう
- 質問内容が明確
- 自分も答えを知りたい
- 質問者以外のユーザにも役立つ
評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。
質問の評価を上げたことを取り消します
-
評価を下げられる数の上限に達しました
評価を下げることができません
- 1日5回まで評価を下げられます
- 1日に1ユーザに対して2回まで評価を下げられます
質問の評価を下げる
teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。
- プログラミングに関係のない質問
- やってほしいことだけを記載した丸投げの質問
- 問題・課題が含まれていない質問
- 意図的に内容が抹消された質問
- 広告と受け取られるような投稿
評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。
質問の評価を下げたことを取り消します
この機能は開放されていません
評価を下げる条件を満たしてません
質問の評価を下げる機能の利用条件
この機能を利用するためには、以下の事項を行う必要があります。
- 質問回答など一定の行動
-
メールアドレスの認証
メールアドレスの認証
-
質問評価に関するヘルプページの閲覧
質問評価に関するヘルプページの閲覧
0
EXCEL-VBAはシングルスレッドでしか動かないので、タイマーで制御するような使い方は困難です。
例えば、
・別のEXCELプロセスを起動して、その別プロセスから10秒毎に元のプロセスのプロシージャをコールする。
など一工夫必要になります。
以下追記しました。
--timer.xlsmの標準モジュール--
Option Explicit
Dim TARGET_APP As Application
Dim TARGET_BOOK As Workbook
Public Sub SetTarget(bookName As String)
Set TARGET_BOOK = GetObject(bookName)
Set TARGET_APP = TARGET_BOOK.Application
End Sub
Public Sub StartTimer(procedureName As String, numOfTimes As Long, waitingTime As Long)
Dim myTime As Date
myTime = Now()
Dim count As Long
For count = 0 To numOfTimes
Application.Wait TimeSerial(Hour(myTime), Minute(myTime), Second(myTime) + waitingTime * count)
TARGET_APP.Run procedureName
Next count
End Sub
--TextBook.xlsmの標準モジュール--
Option Explicit
Dim TIMER_BOOK As Workbook
Const TIMER_BOOK_FILENAME = "D:\timer.xlsm"
Public Sub Test()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim tmpFileName As String
tmpFileName = fso.GetSpecialFolder(2) & "\" & fso.GetBaseName(fso.GetTempName) & ".xlsm"
FileCopy TIMER_BOOK_FILENAME, tmpFileName
Dim otherApp As Application
Set otherApp = New Application
Set TIMER_BOOK = otherApp.Workbooks.Open(tmpFileName)
With TIMER_BOOK.Application
.Run "SetTarget", ThisWorkbook.FullName
.Run "StartTimer", "MoveNext", 10, 10
End With
End Sub
Public Sub End_Test()
If (Not TIMER_BOOK Is Nothing) Then
Dim bookName As String
bookName = TIMER_BOOK.FullName
TIMER_BOOK.Application.Quit
Kill bookName
End If
End Sub
Public Sub MoveNext()
'省略
End Sub
投稿
-
回答の評価を上げる
以下のような回答は評価を上げましょう
- 正しい回答
- わかりやすい回答
- ためになる回答
評価が高い回答ほどページの上位に表示されます。
-
回答の評価を下げる
下記のような回答は推奨されていません。
- 間違っている回答
- 質問の回答になっていない投稿
- スパムや攻撃的な表現を用いた投稿
評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。
0
案1
Application.OnTimeで所定時間経過後に関数の呼び出しができますがいかがでしょうか?
※使い方は以下のサイトが参考になります。
⇒すぐに役立つExcelVBAマクロ集
Sub prcTimer()
Dim iRow As Integer
'とりあえずB2セルを出力行番号として処理しています。
iRow = Val(Cells(1, 2))
Dim tNextTime
iRow = iRow + 1
Cells(1, 2) = iRow
If iRow > 10 Then
'10行書いたら終了
Cells(1, 2) = 0
MsgBox "終了"
Exit Sub
End If
Cells(iRow, 1).Activate
'所定時間(ここでは3秒後)になったら再度この関数を呼び出すようタイマーセット
tNextTime = TimeValue(Now) + TimeValue("00:00:03")
Application.OnTime tNextTime, "prcTimer"
End Sub
ただ、この方法ではセルの入力中に指定時間を迎えた場合、入力が終わるのを待ってから次の処理が発生となります。
このため、セル入力中でも強制的に次のセルに移動するようなことはできません。
案2
別案として、Inputboxのようなテキスト入力用のフォームを表示し、値を入力させる方法を提案してみます。
テキスト入力フォームを表示して、そのフォームで入力した値をセルにも反映させていくような形です。
フォーム表示後、所定の時間が経過したら強制的にフォームを終了し、次の項目のテキスト入力用フォームとして開き直すような流れになると思います。
入力方法がだいぶ変わってしまうのでだめかもしれませんが、案として参考までに。
ちなみにタイマー処理自体は案1と同じApplication.OnTimeです。
(標準モジュールに記述するコード)
'テキスト入力用フォームの起動処理
Sub Start()
'とりあえずB2セルに出力行番号を格納して終了判定
If Cells(1, 2) > 10 Then
'10行書いたら終了
Cells(1, 2) = 0
Exit Sub
End If
'テキスト入力用フォームを表示
UserForm1.Show
End Sub
'所定時間後に行う処理
Sub SetVal()
'B2セルから出力行番号を取得
Dim iRow As Integer
iRow = Val(Cells(1, 2))
Dim tNextTime
'B2セルに出力行番号を格納
iRow = iRow + 1
Cells(1, 2) = iRow
'テキスト入力用フォームでの入力値をセルに反映
Cells(iRow, 1) = UserForm1.TextBox1
'テキスト入力用フォームの終了
Unload UserForm1
'テキスト入力用フォームを起動
Start
End Sub
(ユーザーフォームに記述するコード)
'フォーム起動時の処理
Private Sub UserForm_Initialize()
Dim tNextTime
'所定時間(ここでは3秒後)になったらSetVal関数を呼び出すようタイマーセット
tNextTime = TimeValue(Now) + TimeValue("00:00:03")
Application.OnTime tNextTime, "SetVal"
End Sub
投稿
-
回答の評価を上げる
以下のような回答は評価を上げましょう
- 正しい回答
- わかりやすい回答
- ためになる回答
評価が高い回答ほどページの上位に表示されます。
-
回答の評価を下げる
下記のような回答は推奨されていません。
- 間違っている回答
- 質問の回答になっていない投稿
- スパムや攻撃的な表現を用いた投稿
評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。
0
そもそもの話になってしまい恐縮ですが、セルの順番にアクティベートする操作を、本当にマクロで自動化しなければいけないのでしょうか。
マトリクスを作成した後、入力領域を範囲選択し(←ここが大事です)、入力→TAB押下→入力...と操作を繰り返していけば、普通に順番に入力できると思います。
追記:
不要とは思いましたが、念のためアクティベートを自動で行う処理を追加しました。
仕組みとしては、マクロの最後で10秒に1回TABキーを押下するPowerShellコマンドを実行しています。
入力領域が範囲選択されていることが前提となりますので、方向キーなどで範囲選択を解除しないようにご注意下さい。
質問者様のVBAコードを一部修正したものも載せておきます。
(修正したのは最後の処理のみで、あとはインデントを付けただけです)
Sub test_マトリクス順次入力()
ReDim Files_1(0)
ReDim Files_2(0)
Dim this_book As Workbook
Dim this_sheet As Worksheet
Set this_book = Workbooks("自動マクロトレーニング.xlsm")
Set this_sheet = this_book.Worksheets("マトリクス順次入力")
Dim i As Long
i = 3
Do Until Cells(i, 3) = ""
n = UBound(Files_1)
ReDim Preserve Files_1(n + 1)
Files_1(n + 1) = Cells(i, 3)
i = i + 1
Loop
Dim j As Long
j = 3
Do Until Cells(j, 4) = ""
m = UBound(Files_2)
ReDim Preserve Files_2(m + 1)
Files_2(m + 1) = Cells(j, 4)
j = j + 1
Loop
For k = 1 To UBound(Files_1)
this_sheet.Cells(k + 2, 6) = Files_1(k)
Next
For l = 1 To UBound(Files_2)
this_sheet.Cells(2, 6 + l) = Files_2(l)
Next
'入力領域を範囲選択
this_sheet.Activate
this_sheet.Range(Cells(2 + 1, 6 + 1), Cells(2 + UBound(Files_1), 6 + UBound(Files_2))).Select
'自動アクティベート
Call 連続キー押下("{TAB}", UBound(Files_1) * UBound(Files_2))
End Sub
Sub 連続キー押下(ByVal keyString As String, ByVal cnt As Long, Optional ByVal interval As Integer = 10)
Dim command As String
command = ""
'PowerShellコマンド生成
' 初期処理
command = command & "[void][Reflection.Assembly]::LoadWithPartialName('System.Windows.Forms');"
command = command & "$keyString='" & keyString & "';"
command = command & "$cnt=" & cnt & ";"
command = command & "$interval=" & interval & ";"
' PowerShellウィンドウが表示されフォーカスが移るため、Alt+Tab押下でExcelにフォーカスを戻す
command = command & "[System.Windows.Forms.SendKeys]::SendWait('%{TAB}');"
' 連続キー押下
command = command & "for($i=0;$i -lt $cnt;$i++){"
command = command & " sleep -s $interval;"
command = command & " [System.Windows.Forms.SendKeys]::SendWait($keyString);"
command = command & "}"
'PowerShellコマンド実行
Call CreateObject("Wscript.Shell").Exec("powershell -command """ & command & """")
End Sub
投稿
-
回答の評価を上げる
以下のような回答は評価を上げましょう
- 正しい回答
- わかりやすい回答
- ためになる回答
評価が高い回答ほどページの上位に表示されます。
-
回答の評価を下げる
下記のような回答は推奨されていません。
- 間違っている回答
- 質問の回答になっていない投稿
- スパムや攻撃的な表現を用いた投稿
評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。
15分調べてもわからないことは、teratailで質問しよう!
- ただいまの回答率 89.99%
- 質問をまとめることで、思考を整理して素早く解決
- テンプレート機能で、簡単に質問をまとめられる
質問への追記・修正、ベストアンサー選択の依頼
Zuishin
2016/07/18 15:54
読みにくくないですか?
インデントが無くなっていますので、コード領域内に書いてください。
再度編集して、プレビューを見ながら読みやすくなるようマークダウンを使ってください。
Zuishin
2016/07/18 18:31
''' ではなく ‘‘‘ です。編集画面の上の方に </> のようなボタンがありますので、それをお使いください。