特定の時点でマクロを中断する方法

Question

私は、乱数を生成してキューブ上の最も遠い点を見つけるVBAマクロを作成しています。それは動作しますが、何も何もしていない時にはしばしば失敗するので、マクロを時々中断する必要があります。

しかし、ある瞬間に中断したいだけで、通常のCtrl + Breakキーボードショートカットはプロセスの途中でマクロを中断する可能性があります。これは私が使用している座標値を暴くことがあります。だから私は、特定の瞬間にマクロを中断する方法が望ましく、キーを押すことが好ましい。

必要な場合は、ここでのコードは次のとおりです。MrExcelの

Sub optimize() 
Dim Distance As Double 
Dim OldNumber As Double 
Dim OldNumbers(1 To 3) As Double 
Dim l As Double 
Dim n As Integer 
Dim m As Integer 
Distance = Range("H14").Value 'This cell contains the distance between the closest 2 points in the coordinates, using =MIN() 
l = 0 
LoopIt: 
l = l + 1 
For n = 0 To 7 
For m = 0 To 2 'The coordinates are stored at F4:H11. 
OldNumber = Range("F4").Offset(n, m).Value 
If Rnd() > 0.01 Then 
Range("F4").Offset(n, m).Value = OldNumber + Rnd()/10000 - 0.00005 'Just slighty nudge the values... 
Else 
Range("F4").Offset(n, m).Value = Rnd() '...but only sometimes. 
End If 
If Range("F4").Offset(n, m).Value > 1 Then Range("F4").Offset(n, m).Value = 1 
If Range("F4").Offset(n, m).Value < 0 Then Range("F4").Offset(n, m).Value = 0 'Making sure the values don't go too high or low 
If Range("H14").Value >= Distance Then 'Are the closest points as far away as before? If so, that's Ok. 
    If Range("H14").Value > Distance Then 'Are the closest points further away? If so, reset counter. 
    l = 0 
    End If 
Distance = Range("H14").Value 
Else 'Are the closest points closer? If so, reset. 
Range("F4").Offset(n, m).Value = OldNumber 
End If 
Next m 
OldNumbers(1) = Range("F4").Offset(n, 0).Value 
OldNumbers(2) = Range("F4").Offset(n, 1).Value 
OldNumbers(3) = Range("F4").Offset(n, 2).Value 
Range("F4").Offset(n, 0).Value = Rnd() 
Range("F4").Offset(n, 1).Value = Rnd() 
Range("F4").Offset(n, 2).Value = Rnd() 'I don't know why I put this in, but it might become useful sometime. 
If Range("H14").Value >= Distance Then 'Are the closest points as far away as before? If so, that's Ok. 
    If Range("H14").Value > Distance Then 'Are the closest points further away? If so, reset counter. 
    l = 0 
    End If 
Distance = Range("H14").Value 
Else 'Are the closest points closer? If so, reset. 
Range("F4").Offset(n, 0).Value = OldNumbers(1) 
Range("F4").Offset(n, 1).Value = OldNumbers(2) 
Range("F4").Offset(n, 2).Value = OldNumbers(3) 
End If 
Next n 
'I only want to interrupt here. 
If l > 10000 Then 'Has it found nothing for so long? Then quit. 
'I sometimes adjust the barrier l needs to hit to very high values so it can compute on its own for a long ass-time without any input. 
MsgBox ("Done!") 
Exit Sub 
End If 
GoTo LoopIt 
End Sub 

Answer 1

VOGはa nice answerを持っているようです。あなたのケースでは

Type KeyboardBytes 
    kbb(0 To 255) As Byte 
End Type 

Declare Function GetKeyboardState Lib "User32.DLL" (kbArray As KeyboardBytes) As Long 

Sub StartLotteryDraw() 
Dim kbArray As KeyboardBytes 
Application.Cursor = xlWait 
Do 
    Calculate 
    DoEvents 
    GetKeyboardState kbArray 
    If kbArray.kbb(32) And 128 Then 
     Application.Cursor = xlNormal 
     Exit Sub 
    End If 
Loop 
End Sub 

は、あなたのコードの末尾には、このチェックを入れて、またはコードの各反復は、それがあなたのキー入力を検出しないように長い時間がかかる場合は、コード全体少数のチェックを追加し、それを使用します変数を設定し、最後に変数をテストします。

Type KeyboardBytes 
    kbb(0 To 255) As Byte 
End Type 

Declare Function GetKeyboardState Lib "User32.DLL" (kbArray As KeyboardBytes) As Long 

あなたのvar宣言に次の行を追加します：たとえば

Dim doInterrupt As Boolean 

置き、この行のコードで3-4ヶ所、上記のコードにかかる時間に均等な間隔の相対実行する：

If doInterrupt = False Then doInterrupt = CheckInterrupt 

はあなたのコードのこの部分を変更します。

を

最後に

If l > 1000000 Or doInterrupt = True Then 

、あなたのコードの後に​​この関数を追加します：このような何かへ

If l > 10000 Then 

Function CheckInterrupt() As Boolean 
    Dim kb As KeyboardBytes 
    GetKeyboardState kb 

    If kb.kbb(32) And 128 Then CheckInterrupt = True 
End Function