Question

我正在运行一个可能需要一些时间在Excel中的宏。有时我可能需要提前终止宏。因此，这会导致宏不执行它的清理功能，例如：Application.ScreenUpdating = True，因为它在我使用的False语句之前设置为Do...Loop。这会导致明显的问题，我通常会在宏的最开头添加True语句后跟End，以解决问题。

我可以使用任何方法在我的代码中启用后终止GoTo语句吗？我理解它可能不是我点击Esc的时候，但是一个类似于MsgBox的持久性盒子呢？但是一个不能阻止代码运行的盒子？我可以将此框基本上用作取消按钮，并且此框可以在宏的整个持续时间内保持不变而不会中断宏的操作。单击所述框中的取消按钮后，它将立即停止正常操作并按照我的GoTo命令执行必要的清理任务。

我有一种强烈的感觉，这是不可能的，但我想我会问那些最了解VBA的人。

Option Explicit

Dim ATC As AccuTermClasses.AccuTerm, A As Session, Sheet As Worksheet

Function RemoveSpaces(MyString As String) As String
    Do Until Right(MyString, 1) <> " "
        MyString = Left(MyString, Len(MyString) - 1)
    Loop
    RemoveSpaces = MyString
End Function

Sub CopyEntireFeeBoard()

    Set ATC = GetObject(, "AtWin32.AccuTerm")
    Set Sheet = Workbooks("2016 FEE BOARD.XLSM").ActiveSheet
    Set A = ATC.ActiveSession

    Dim xlRow As Long, aRow As Integer   'Excel's and AccuTerm's Row #s
    Dim Rate As Single, Name As String, Client As String, Desk As Byte
    xlRow = 2   'Starting row
    aRow = 3

    Application.Calculation = xlCalculationManual
    Do
        Rate = 0
        On Error Resume Next    'Incase Rate is blank
        Rate = A.GetText(47, aRow, 4, 1)
        On Error GoTo 0

        Client = RemoveSpaces(A.GetText(10, aRow, 7, 1))
        If Client = "100AAA" Then Client = ""
        Name = RemoveSpaces(A.GetText(26, aRow, 16, 1))
        Desk = A.GetText(56, aRow, 2, 1)

        Sheet.Cells(xlRow, 1).Value = A.GetText(0, aRow, 8, 1)      'Date
        Sheet.Cells(xlRow, 2).Value = Client                        'Client
        Sheet.Cells(xlRow, 3).Value = A.GetText(18, aRow, 7, 1)     'DNUM
        Sheet.Cells(xlRow, 4).Value = Name                          'Name
        Sheet.Cells(xlRow, 5).Value = A.GetText(43, aRow, 3, 1)     'TC
        If Rate <> 0 Then Sheet.Cells(xlRow, 6).Value = Rate        'Rate
        Sheet.Cells(xlRow, 7).Value = A.GetText(52, aRow, 3, 1)     'STS
        Sheet.Cells(xlRow, 8).Value = Desk                          'DESK
        Sheet.Cells(xlRow, 9).Value = A.GetText(59, aRow, 10, 1)    'AMOUNT
        xlRow = xlRow + 1
        aRow = aRow + 1

        ' Reached the end of host application's page.
        If aRow = 22 Then

            'Will go ahead and refresh Excel at this point
            Application.Calculation = xlCalculationAutomatic

            aRow = 3 'Reset AccuTerm's Starting Row
            A.Output Chr(13)    'Enter key

            ' Give time for the next screen to refresh
            Application.Wait Now + TimeValue("00:00:01")
            Application.Calculation = xlCalculationManual
        End If

    Loop Until A.GetText(26, aRow, 1, 1) = " "

    Application.Calculation = xlCalculationAutomatic

    Set ATC = Nothing
    Set Sheet = Nothing
    Set A = Nothing

End Sub

Answer 1

如果在按下 End 键时Do Loop，我修改了您的代码以退出。

此外，在退出循环后，数据被收集到一个数组中并在一个操作中写入工作表。这样，就无需切换计算和屏幕更新。

内置的VBA函数RTrim与RemoveSpaces执行的操作相同，但效率更高。

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long
Const VK_END = &H23

Dim ATC As AccuTermClasses.AccuTerm, A As Session

Sub CopyEntireFeeBoard()

    Set ATC = GetObject(, "AtWin32.AccuTerm")
    Set A = ATC.ActiveSession
    Dim AllData, RowData(1 To 9)

    Dim xlRow As Long, x As Long   'Excel's and AccuTerm's Row #s
    Dim Rate As Single, Name As String, Client As String, Desk As Byte
    aRow = 3
    ReDim AllData(0)

    Do
        ReDim Preserve AllData(x)

        Rate = 0
        On Error Resume Next    'Incase Rate is blank
        Rate = A.GetText(47, aRow, 4, 1)
        On Error GoTo 0

        Client = RTrim(A.GetText(10, aRow, 7, 1))
        If Client = "100AAA" Then Client = ""
        Name = RemoveSpaces(A.GetText(26, aRow, 16, 1))
        Desk = A.GetText(56, aRow, 2, 1)

        RowData(1).Value = A.GetText(0, aRow, 8, 1)       'Date
        RowData(2).Value = Client                        'Client
        RowData(3).Value = A.GetText(18, aRow, 7, 1)     'DNUM
        RowData(4).Value = Name                          'Name
        RowData(5).Value = A.GetText(43, aRow, 3, 1)     'TC
        If Rate <> 0 Then RowData(6).Value = Rate        'Rate
        RowData(7).Value = A.GetText(52, aRow, 3, 1)     'STS
        RowData(8).Value = Desk                          'DESK
        RowData(9).Value = A.GetText(59, aRow, 10, 1)    'AMOUNT

        AllData(x) = RowData
        aRow = aRow + 1

        ' Reached the end of host application's page.
        If aRow = 22 Then

            aRow = 3 'Reset AccuTerm's Starting Row
            A.Output Chr(13)    'Enter key

            ' Give time for the next screen to refresh
            Application.Wait Now + TimeValue("00:00:01")

        End If

        x = x + 1
    Loop Until A.GetText(26, aRow, 1, 1) = " " Or GetKeyState(VK_END)

    'Converts the Array of Arrays into a 2 Dimensional array
    AllData = Transpose(AllData)
    AllData = Transpose(AllData)

    With Workbooks("2016 FEE BOARD.XLSM")
        .Range("A1").Resize(UBound(data, 1) + 1, 9).Value = AllData
    End With

    Set ATC = Nothing
    Set Sheet = Nothing
    Set A = Nothing

End Sub

Answer 2

添加例如UserForm，其中一个按钮用于执行长时间运行的操作，另一个按钮用于提前终止。当您决定提前终止操作时，只需单击 cancel 按钮设置bool变量，do-loop将退出。

用户表单代码 （添加两个名为CancelCommandButton和ExecuteCommandButton的命令按钮）

Private Sub CancelCommandButton_Click()
    CancelRequest = True
End Sub

Private Sub ExecuteCommandButton_Click()
    Me.Repaint
    CancelRequest = False
    LongRunningTask
End Sub

标准模块代码

Public CancelRequest As Boolean

Public Sub LongRunningTask() ' e.g. like CopyEntireFeeBoard()
    ' ...

    Dim result As Long
    Do
        result = result + 1

        ' ...

        ' At the and of the loop check the bool variable and exit if necessary
        DoEvents
        If CancelRequest Then
            ' Do some cleanup
            Exit Do
        End If
    Loop Until result = 100000000 ' A.GetText(26, aRow, 1, 1) = " "

    ' ...
End Sub

在过早终止代码时使用退出代码清理

2 个答案: