Question

我正在创建一个VBA宏，它会生成随机数以找到多维数据集上最远的点。它可以工作，但它经常绊倒太久而没有任何价值，所以我需要有时中断宏。

但是，我只想在某个时刻中断，而正常的Ctrl + Break键盘快捷键可以在进程中间中断宏，这可能会破坏我正在使用的坐标值。所以我想要一种方法在某些时刻中断宏，最好是按键。

如果需要，这是代码：

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

MrExcel的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 > 10000 Then

这样的事情：

If l > 1000000 Or doInterrupt = True Then

最后，在代码后添加此函数：

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

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

一种在某些时刻中断宏的方法

1 个答案: