エクセルVBAを中断する場合

質問

簡略化してますが、下記のVBAコードはDATAシートから1行ずつデータをBBBシートに読み込み、プリントまたはプリントプレビューするものです。
予期したとおりに作動するのですが、1点不満があります。
途中でやめることが出来ないのです。もちろんＥｓｃキーを長押しすればエラーになって止まりますが、そうするとステータスバーの表示が残ったままになります。
On Error GoTo で、Application.StatusBar = ""に飛ぶようにしているのですがＥｓｃキー長押しのエラーでは飛ばないようです。

１．どうやったらすんなり止めることができるでしょうか？
２．その他、改善点がありましたらご指摘ください。

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Option Explicit

Sub DM_OutPut()

Dim myYN As Integer, myYN2 As Integer, s As Long, n As Long, x As Long, tx As String
Dim ds As Worksheet, bs As Worksheet, base As Range

s = 300

myYN = MsgBox("データはDATAシートに切れ目なくセットされてますか？", vbYesNo + vbQuestion, " （＾∇＾）？")
If myYN = vbNo Then
Exit Sub
Else
myYN2 = MsgBox("本番印刷行きますか？" _
& vbCrLf & "すぐ行っちゃうなら「はい」を、" _
& vbCrLf & "テストでプレビュー画面出すなら「いいえ」をクリックしてください。" _
& vbCrLf & "" _
& vbCrLf & "プレビューは1画面 約" & Format(s, "#,##0") & "ミリ秒間表示します。", vbYesNo + vbQuestion, " （＾∇＾）？")
End If

Set ds = Sheets("DATA")
Set bs = Sheets("BBB")
Set base = ds.Range("B3") '基準点

bs.Rows(3).ClearContents

Do While 1

On Error GoTo line

If base.Offset(n).Value = "" Then Exit Do '基準点以下にデータのある限り続ける

bs.Rows(3).Value = base.Offset(n).EntireRow.Value

n = n + 1 'カウント

Application.StatusBar = Format(n, "#,##0") & "件目を処理しました。"

If myYN2 = vbNo Then
SendKeys "%C" 'デモ用
ActiveSheet.PrintPreview
tx = "プレビュー"
Else
ActiveSheet.PrintOut Copies:=1 '本番用
tx = "プリント指示"
End If

Sleep s '休みを入れる

Loop

MsgBox Format(n, "#,##0") & "件を" & tx & "しました。", vbInformation, " (o^-')v "

line:

Application.StatusBar = ""

End Sub

回答No.3

pauNed · ベストアンサー

>以下のように使えばいいんですね？
サンプルコードなので、それでいいのでしょうけど、
止めなかった場合のStatusBar表示とMsgBoxが......？
>最後にApplication.EnableCancelKey = xlInterruptで元に戻しました。
終了するとxlInterruptになりますが、明示したほうが良いのでしょうね。
↓ここも参考にしてみてください。
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_090_050.html

お礼

とても参考になりました。
有難うございます。

Sub test2()
Dim i As Long
Dim swEND As Boolean

On Error GoTo erLine
Application.EnableCancelKey = xlErrorHandler

For i = 1 To 10000
Application.StatusBar = i
Cells(i, 1) = i
If swEND = True Then
If MsgBox("中断キーが押されました。" & vbCr & _
"終了しますか？", vbYesNo) = vbYes Then
Exit For
Else
swEND = False
End If
End If
Next i

erLine:
If Err.Number = 18 Then
swEND = True
Resume
ElseIf Err.Number <> 0 Then
MsgBox Err.Number & ":" & Err.Description
End If
Application.EnableCancelKey = xlInterrupt
Application.StatusBar = ""
End Sub

としてみました。

回答No.5

kobouzu_su

大雨注意報の中からこんにちは、kobouzuです。

＞ESCキーだとエラーで止まります・・・。

ESCキー以外（通常のキー、Ctrlキー、Shiftキーなど）ではエラー（というよりマクロ中断ダイアログ）は出ませんよね。

それは、ESCキーがマクロ中断の特別なキーなので
＞If GetAsyncKeyState(vbKeySpace) <> 0 Then
このように、ESCキー以外でチェックしているときに、ESCキーを押下すると本来のESCキーの機能である「マクロ中断ダイアログ」が出るのです。

ですから、今回のようにスペースキーなどのESCキー以外のキーをチェックしているときに、ESCキーが押下されても「本来の中断ダイアログ」を表示させないためには、スペースキーと共に、ESCキーもチェックしなければいけません。

If GetAsyncKeyState(vbKeyEscape) = 0 And _
　　GetAsyncKeyState(vbKeySpace) <> 0 Then
　　　　MsgBox "Dummy"
　　　　Msg = MsgBox("中断しますか？", vbOKCancel, "確認")
　　　　If Msg = vbOK Then Exit For
End If

'---------------------------------------

ESCキーのみで中断したければ
＞If GetAsyncKeyState(vbKeySpace) <> 0 Then
このvbKeySpaceを、vbKeyEscapeに変更して、Msgbox"Dummy"を省くだけです。
ESCキー以外では他のどのキーを押してもエラー（ダイアログ）は出ないし、中断もしません。

　　If GetAsyncKeyState(vbKeyEscape) <> 0 Then
　　　　Msg = MsgBox("中断しますか？", vbOKCancel, "確認")
　　　　If Msg = vbOK Then Exit For
　　End If

ご存知とは思いますがvbKeySpaceとかvbKeyEscapeなどをキーコード定数とよびます。

　　Ctrlキー　　＞　vbKeyControl
　　Shiftキー　　＞　vbKeyShift

詳しくは、キーコード定数をご覧あれ。

もちろん通常のCODEを使ってもかまいません。

If GetAsyncKeyState(vbKeyEscape) <> 0 Then
If GetAsyncKeyState( 27 ) <> 0 Then

　　ESC　　－＞　２７
　　Space　－＞　３２　

--------------------------------------------------

＞MsgBox "Dummy"
＞これ、わかりません。スペースキーを押しても表示されませんね。

これは夏休みの宿題ということで。。(^^;;;

で、いまのところ先の回答にも書きましたように以下のように覚えおくといいでしょう。

通常のキー（あいう、1234、Enterなど）をチェックに使うときは、MsgBox"Dummy"　が、必要。
それ以外のキー（ESC、Ctrl、Shiftなど）をチェックに使うときは、MsgBox"Dummy"　は、不要。

うーん、相変わらず分かり難い説明なり～。。。(^^;;;

以上です。

お礼

大雨の中、有難うございます。
九州の方は随分ひどいようですね。大丈夫ですか？

> ご存知とは思いますがvbKeySpaceとかvbKeyEscapeなどをキーコード定数とよびます。

知りませんでした。勉強になります。
有難うございました。

回答No.4

kobouzu_su

エキスパートさん、こんばんは。

梅雨の晴れ間をぬっての回答です。(^^;;;

お好みのキーで中断するのはどうでせう。例、スペースキー
'---------------------------------------------------------
Option Explicit

Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Sub Test()
　Dim K As Long
　Dim Msg As Integer

　For K = 1 To 1000000
　　　Application.StatusBar = K

　　　If GetAsyncKeyState(vbKeySpace) <> 0 Then
　　　　　MsgBox "Dummy"
　　　　　Msg = MsgBox("中断しますか？", vbOKCancel, "確認")
　　　　　If Msg = vbOK Then Exit For
　　　End If

　Next K
　　　Application.StatusBar = ""
End Sub
'-----------------------------------------------------------

これだとお好みのキーで中断できまするよ。
但し、ESCキー（vbKeyEscape）、Ctrlキー（vbKeyControl）等の
通常でないキーを使うときは、MsgBox "Dummy"、は不要です。
これは試してみれば分かります。

以上です。

お礼

おや、大師様、いつもありがとうございます。
スペースキーなどでも中断可能なんですね、知りませんでした。
今回はESCきーかCtrl+Breakで処理しようと思いますが、質問のエキスパート？としましては勉強になることばかりです。

> MsgBox "Dummy"

これ、わかりません。スペースキーを押しても表示されませんね。
ESCキーだとエラーで止まります・・・。
わかりませぬぅ・・・。

補足

一応こんな感じで出来ました。
間違ってないですよね？

Sub DM_OutPut()

Dim myYN As Integer, myYN2 As Integer, s As Long, n As Long, x As Long, tx As String
Dim ds As Worksheet, bs As Worksheet, base As Range
Dim swEND As Boolean

s = 300
swEND = False

myYN = MsgBox("データはDATAシートに切れ目なくセットされてますか？", vbYesNo + vbQuestion, " （＾∇＾）？")
If myYN = vbNo Then
Exit Sub
Else
myYN2 = MsgBox("本番印刷行きますか？" _
& vbCrLf & "すぐ行っちゃうなら「はい」を、" _
& vbCrLf & "テストでプレビュー画面出すなら「いいえ」をクリックしてください。" _
& vbCrLf & "" _
& vbCrLf & "プレビューは1データ約" & Format(s, "#,##0") & "ミリ秒間隔で表示します。", vbYesNo + vbQuestion, " （＾∇＾）？")
End If

Set ds = Sheets("DATA")
Set bs = Sheets("BBB")
Set base = ds.Range("B3") '基準点

bs.Rows(3).ClearContents

On Error GoTo erLine
Application.EnableCancelKey = xlErrorHandler

Do While base.Offset(n).Value <> "" '基準点以下にデータのある限り続ける

bs.Rows(3).Value = base.Offset(n).EntireRow.Value

n = n + 1 'カウント

Application.StatusBar = Format(n, "#,##0") & "件目を処理しました。"

If myYN2 = vbNo Then
SendKeys "%C" 'デモ用
ActiveSheet.PrintPreview
tx = "プレビュー"
Else
ActiveSheet.PrintOut Copies:=1 '本番用
tx = "プリント指示"
End If

Sleep s '休みを入れる

If swEND = True Then
If MsgBox("中断キーが押されました。" & vbCr & _
"終了しますか？", vbYesNo + vbQuestion, " （＾∇＾）？") = vbYes Then
Exit Do
Else
swEND = False
End If
End If

Loop

erLine:

If Err.Number = 18 Then
swEND = True
Resume
ElseIf Err.Number <> 0 Then
MsgBox Err.Number & ":" & Err.Description
End If

If swEND = False Then
MsgBox Format(n, "#,##0") & "件を" & tx & "しました。", vbInformation, " (o^-')v "
End If

Application.EnableCancelKey = xlInterrupt
Application.StatusBar = ""

End Sub

回答No.2

pauNed

こんにちは。
EnableCancelKey プロパティについて調べてみましょう。

Sub test()
　　Dim i As Long

　　On Error GoTo erLine
　　Application.EnableCancelKey = xlErrorHandler
　　For i = 1 To 1000000000: Next i
erLine:
　　If Err.Number <> 0 Then MsgBox Err.Number & ":" & Err.Description
End Sub

お礼

pauNedさま、有難うございます。
EnableCancelKey ですか、また新しい呪文をひとつ覚えました。
以下のように使えばいいんですね？
Ctrl+BreakやEscキーで止めた場合は、StatusBarをクリアします。
最後にApplication.EnableCancelKey = xlInterruptで元に戻しました。

Sub test2()
Dim i As Long
On Error GoTo erLine
Application.EnableCancelKey = xlErrorHandler
For i = 1 To 1000000000
Application.StatusBar = i
Next i
erLine:
If Err.Number = 18 Then
MsgBox "中止します。"
Application.StatusBar = ""
Else
MsgBox Err.Number & ":" & Err.Description
End If
Application.EnableCancelKey = xlInterrupt
End Sub

回答No.1

ぜ り～（@-Jelly-）

>１．どうやったらすんなり止めることができるでしょうか？

実行中止めたいのなら
Ctrl + Breakでとまります。

End Subの直前に
Application.StatusBar = ""
を入れておいて、
とまったら実行行をそこにもっていって、
F8で追加した１行を実行させて、次の行のEcdSubへ移動すれば良いかと思います。

手作業になりますが。

お礼

さっそく有難うございます。
ただ、

> End Subの直前に
> Application.StatusBar = ""
> を入れておいて、

質問で書いたとおり、それはもうすでに入っています。

> 手作業になりますが。

すみません、VBAの質問をしています。