Verwenden Sie Exit Code Cleanup, wenn Sie Code vorzeitig beenden

Question

Ich verwende ein Makro, das einige Zeit in Excel dauern kann. Es kann vorkommen, dass ich das Makro vorzeitig beenden muss. Dies führt dazu, dass das Makro seine Bereinigungsfunktionen nicht ausführt, z. B. Application.ScreenUpdating = True, da es vor der Anweisung, die ich verwende, auf False gesetzt ist. Dies wird offensichtliche Probleme verursachen, und ich schließe normalerweise die True Anweisung, gefolgt von End am Anfang des Makros, nur um das Problem zu beheben.

Gibt es eine Methode, die ich verwenden kann, um eine nach-terminieren GoTo-Anweisung in meinem Code zu aktivieren? Ich verstehe, dass es nicht sein könnte, wenn ich auf Esc klicke, aber was ist mit einer persistenten Box, ähnlich einer MsgBox - aber eine, die den Code nicht zum Laufen bringt? Ich kann diese Box im Grunde als eine Abbrechen-Schaltfläche verwenden, und diese Box kann für die gesamte Dauer des Makros aufbleiben, ohne die Makro-Operation zu unterbrechen. Nach dem Klicken auf die Abbrechen-Schaltfläche in diesem Feld wird sofort der normale Betrieb eingestellt und der Befehl GoTo ausgeführt, der die erforderlichen Aufräumarbeiten ausführt.

Ich habe das starke Gefühl, dass dies nicht möglich ist, aber ich dachte, ich würde diejenigen fragen, die VBA am besten kennen.

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

ich wieder Ihren Code zu verlassen, wenn die Do Loop, wenn die Ende Taste gedrückt wird.

Zusätzlich werden die Daten in einem Array gesammelt und in einem Arbeitsgang in das Arbeitsblatt geschrieben, nachdem die Schleife beendet wurde. Auf diese Weise müssen Berechnungen und Bildschirmaktualisierung nicht umgeschaltet werden.

Die integrierte VBA-Funktion RTrim macht dasselbe, was RemoveSpaces tut, ist aber effizienter.

---

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

Hinzufügen z.B. UserForm, die eine Taste für Ausführung der lang andauernden Betrieb und eine andere Taste für vorzeitige Terminierung haben wird. Wenn Sie sich entscheiden, den Vorgang vorzeitig zu beenden, klicken Sie einfach auf die Schaltfläche Abbrechen, die die Bool-Variable setzt und Do-Schleife wird beendet.

User Form Code (fügen Sie zwei Befehlsschaltflächen namens CancelCommandButton und ExecuteCommandButton)

Private Sub CancelCommandButton_Click() 
    CancelRequest = True 
End Sub 

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

Standard Module Code

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