VBA - Escape Key and Error Handler

vba_monkey · Aug 9th 2017

Hello,

I am trying to get excel to go to my error handler if Esc is pressed whilst the macro is running. This is what I have so far but when I press Esc, Excel goes to the error handler and breaks on the first line with error 'User interrupt occurred' instead of running through the code in the error handler:

Code

On Error GoTo Error_Handler


Application.EnableCancelKey = xlErrorHandler


Error_Handler:
If Err = 18 Then
    MsgBox "Macro exited...", vbExclamation, "Stopped!"
Else
    Debug.Print "Line: " & Erl & "  Desc: " & Err.Description
    MsgBox "An error occurred, exiting macro...", vbCritical, "Error!"
End If

Display More

Any ideas please?

Also posted here:
https://www.mrexcel.com/forum/…pe-key-error-handler.html

**Carim** · Aug 11th 2017

Re: VBA - Escape Key and Error Handler

Hello,

You can take a look at following link:

https://msdn.microsoft.com/en-us/library/aa214566(office.11).aspx

Hope this will help

vba_monkey · Aug 11th 2017

Re: VBA - Escape Key and Error Handler

Thanks, I've already seen that but it doesnt really answer why my code isnt working as it says it should in that article. I have a Go To statement and EnableCancelKey is set to xlErrorHandler. If Esc is pressed then it goes tp the error handler as it should but then seems to return to xlInterrupt without running through the code in the error handler.

**KjBox** · Aug 11th 2017

Re: VBA - Escape Key and Error Handler

This worked fine for me

Code

Sub Test2()


On Error GoTo Error_Handler
Application.EnableCancelKey = xlErrorHandler


For x = 1 To 100000000
    y = x
Next


Error_Handler:
If Err = 18 Then
    MsgBox "Macro exited...", vbExclamation, "Stopped!"
Else
    MsgBox "An error occurred (" & Err.Description & "), exiting macro...", vbCritical, "Error!"
End If


End Sub

Display More

Pressing esc key gives the first error message.

Changing

Code

y = x

to

Code

y = x / 0

gave the second message.

Replacing the For.......Next loop with your actual code should make it work OK with your actual code.

vba_monkey · Aug 11th 2017

Re: VBA - Escape Key and Error Handler

I can get it to work too on a blank sheet so there's obviously something going wrong in my workbook. Here's the full code, I'm not sure you'll be able to test as it involves updating pivot tables that are connect to a network data source.

I thought it might be this part that is doing it but commenting them out has no effect:

Code

Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

Full code:

Code

Private Sub OKButton_Click()


    On Error GoTo Error_Handler
    Dim Events As Boolean, Calc As Integer, ScrnUpd As Boolean, Alerts As Boolean
    Dim StartTime As Date, StopTime As Date, Elapsed As Date
    Dim FileName As String, Filepath As String
    Dim cond1() As String
    Dim cond3 As String
    Dim i As Long, j As Long, k As Long
    Dim Branch_Name As String, Branch As Variant
    Dim LastRow As Long
    Dim copy_start As Long, copy_end As Long
    Dim str1 As String, str2 As String
    Dim ws As Worksheet
    Dim Logo As Shape
    Dim f As String
    Dim Quarter As Integer
    
    Application.EnableCancelKey = xlErrorHandler
    
    Create_Reports_Form.Hide
    
    Events = Application.EnableEvents
    Calc = Application.Calculation
    ScrnUpd = Application.ScreenUpdating
    Alerts = Application.DisplayAlerts


'   Select File for previous report
    f = Application.GetOpenFilename(Title:="Select File")


'   Exit if cancel is selected
    If f = "False" Then Exit Sub


'   Set Filename
    FileName = Dir(f, vbDirectory)
    
    Call Show_Macro_Running_Form
    
    StartTime = Time
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Sheets("List").Visible = True
    Branch = Worksheets("List").Range("Branch")
    Set Logo = Sheets("List").Shapes("Picture 2")
    Quarter = (Month(Date) + 2) \ 3
    
'   Set UW months


    ReDim cond1(cmbMonthTo - cmbMonthFrom)
    
    For i = 0 To cmbMonthTo - cmbMonthFrom
        cond1(i) = "[DIM Policy UW Year Month].[Policy UW Month].&[" & Format(cmbMonthFrom + i, "00") & "]"
    Next i
    
    With Sheets("Policy")
        ActiveWorkbook.SlicerCaches("Slicer_Policy_UW_Month2").VisibleSlicerItemsList = Array(cond1)
    End With


    For i = 1 To 7 'When testing please change
    
        cond3 = "[DIM Branch].[BRANCH NAME].&[SJNKE " & Branch(i, 1) & "]"
        ActiveWorkbook.SlicerCaches("Slicer_BRANCH_NAME2").VisibleSlicerItemsList = Array(cond3)
        
        Call Variance2


        Worksheets.Add
        Range("A19").Select
        ActiveWindow.FreezePanes = True
        ActiveWindow.DisplayGridlines = False
        
        ActiveSheet.Name = Branch(i, 1)
        Branch_Name = Branch(i, 1)
 
        Worksheets("Policy").Range("TableHeaders").Copy Destination:=Sheets(Branch_Name).Cells(16, 1)
        Worksheets("Policy").Range("ColumnWidths").Copy
        Worksheets(Branch_Name).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
        
        
        Sheets("Policy").Select
        copy_start = Cells.Find(What:="INSURED NAME").Row + 1
        
        For k = Cells.Find(What:="INSURED NAME").Row + 1 To Cells(Rows.Count, 1).End(xlUp).Row
            
            If Cells(k, 19).Value = "CHECK" Or Cells(k, 22).Value = "CHECK" Then
                copy_end = k
                Range(Cells(copy_start, 1), Cells(copy_end, 22)).Copy
                Sheets(Branch_Name).Select
                Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
                Selection.PasteSpecial Paste:=xlPasteAll
                Sheets("Policy").Select
            End If
            
            str1 = Cells(k, 1).Value
            str2 = Cells(k - 1, 1).Value
            
            If Len(str1) > Len(str2) And InStr(str1, str2) Then
                copy_start = k + 1
            End If
            
        Next k
        
'       Format
        Worksheets("List").Range("TableHeaders2").Copy Destination:=Sheets(Branch_Name).Cells(16, 1)
                
        With Sheets(Branch_Name)
                .Range(.Cells(19, 14), .Cells(19, 14).End(xlDown)).Copy
                .Range(.Cells(19, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 11)).PasteSpecial Paste:=xlPasteFormats
                .Cells(1, 2).Value = Branch_Name & " - Q" & Quarter & " " & Year(Date)
                .Cells(1, 2).Font.Bold = True
                .Cells(1, 2).Font.Size = 12
                .Cells(2, 2).Value = "Currency: UK - GBP, Non UK - EUR"
                .Cells(2, 2).Font.Bold = True
                .Cells(2, 2).Font.Size = 10
                .Rows("3:14").Delete
                .Columns(20).Insert
                .Columns(24).Insert
                .Columns(23).Copy
                .Columns(24).PasteSpecial Paste:=xlPasteFormats
                .Columns(20).Insert
                .Rows("2:3").Font.Size = 10
                .Cells(2, 20).Value = "1"
                .Cells(2, 20).HorizontalAlignment = xlCenter
                .Cells(2, 21).Value = "Incorrect. Amendment required."
                .Cells(3, 20).Value = "2"
                .Cells(3, 20).HorizontalAlignment = xlCenter
                .Cells(3, 21).Value = "Correct. No amendment required."
                .Cells(4, 20).Value = "Status"
                .Cells(4, 20).HorizontalAlignment = xlCenter
                .Cells(4, 21).Value = "Comments / Reasons"
        End With
        
 '       Check(1)
        With Sheets(Branch_Name)
            For j = 7 To .Cells(Rows.Count, 1).End(xlUp).Row
                If .Cells(j, 19).Value = "CHECK" Then
                    With .Cells(j, 20).Validation
                        .Delete
                        .Add Type:=xlValidateList, _
                            Operator:=xlEqual, _
                            Formula1:="1,2"
                    End With
                    With .Cells(j, 20)
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With
                End If
            Next j
        End With
        
'       Check(2)
        With Sheets(Branch_Name)
            .Columns(25).Insert
            .Cells(2, 25).Value = "1"
            .Cells(2, 25).HorizontalAlignment = xlCenter
            .Cells(2, 26).Value = "Incorrect. Amendment required."
            .Cells(3, 25).Value = "2"
            .Cells(3, 25).HorizontalAlignment = xlCenter
            .Cells(3, 26).Value = "Correct. No amendment required."
            .Cells(4, 25).Value = "Status"
            .Cells(4, 25).HorizontalAlignment = xlCenter
            .Cells(4, 26).Value = "Comments / Reasons"
        End With
        
        With Sheets(Branch_Name)
            For j = 7 To .Cells(Rows.Count, 1).End(xlUp).Row
                If .Cells(j, 24).Value = "CHECK" Then
                    With .Cells(j, 25).Validation
                        .Delete
                        .Add Type:=xlValidateList, _
                            Operator:=xlEqual, _
                            Formula1:="1,2"
                    End With
                    With .Cells(j, 25)
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                    End With
                End If
            Next j
       End With
       
        With Sheets(Branch_Name)
            .Columns(20).ColumnWidth = 6.75
            .Columns(25).ColumnWidth = 6.75
            .Columns(21).ColumnWidth = 32.5
            .Columns(26).ColumnWidth = 32.5
        End With
        
'       Insert Vlookups to draw through comments
        With Sheets(Branch_Name)
                    LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                    .Range("A:B").EntireColumn.Insert
                    .Range("A7:A" & LastRow).Value = "=$C7&$D7&ROUND($S7,5)"
                    .Range("B7:B" & LastRow).Value = "=$D7&$E7&ROUND($X7,5)"
                    .Range("V7:V" & LastRow).Value = "=IFERROR(IF(VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,22,0)="""","""",VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,22,0)),"""")"
                    .Columns("V").EntireColumn.HorizontalAlignment = xlCenter
                    .Range("W7:W" & LastRow).Value = "=IFERROR(IF(VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,23,0)="""","""",VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,23,0)),"""")"
                    .Range("AA7:AA" & LastRow).Value = "=IFERROR(IF(VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,27,0)="""","""",VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,27,0)),"""")"
                    .Columns("AA").EntireColumn.HorizontalAlignment = xlCenter
                    .Range("AB7:AB" & LastRow).Value = "=IFERROR(IF(VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,28,0)="""","""",VLOOKUP($A7,'[" & FileName & "]" & .Name & "'!$A:$AB,28,0)),"""")"
                    .Columns("A:AB").Copy
                    .Columns("A:AB").PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                    .Columns("A:B").EntireColumn.Hidden = True
                    Logo.Copy
                    .Paste Destination:=Sheets(Branch_Name).Range("C1")
                    .Tab.ThemeColor = xlThemeColorAccent2
        End With
    
    Next i
    
    Worksheets("ALL Branches").Delete
    Worksheets("Summary").Delete
    Worksheets("Policy").Delete
    Worksheets("Version History").Delete
    Worksheets("List").Delete
    
    Sheets(1).Activate
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            .Activate
            .Range("C6").Select
        End With
    Next ws


    Unload Create_Reports_Form
    Unload Macro_Running_Form
    
    StopTime = Time
    
    Filepath = "R:\SJE Shared\DMU\Data Checking\" & Year(Date) & "\Q" & Quarter & "\Gross Premium\"
    ActiveWorkbook.SaveAs FileName:=Filepath & Replace(ActiveWorkbook.Name, "ver_3.0_LIVE.xlsm", Format(Date, "mm") & "_" & Format(Date, "dd") & ".xlsx"), FileFormat:=51, AccessMode:=xlShared
    
    Application.EnableEvents = Events
    Application.Calculation = Calc
    Application.ScreenUpdating = ScrnUpd
    Application.DisplayAlerts = Alerts
    
    Elapsed = StopTime - StartTime
    MsgBox "Refresh completed !!" & vbCrLf & vbCrLf & "Time elapsed: " & Minute(Elapsed) & " minutes " & Second(Elapsed) & " seconds", vbInformation
Exit Sub


'   Reset if exiting due to error
Error_Handler:
If Err = 18 Then
    Application.EnableEvents = Events
    Application.Calculation = Calc
    Application.ScreenUpdating = ScrnUpd
    Application.DisplayAlerts = Alerts
    Unload Create_Reports_Form
    Unload Macro_Running_Form
    Sheets("List").Visible = False
    MsgBox "Macro exited...", vbExclamation, "Stopped!"
Else
    Application.EnableEvents = Events
    Application.Calculation = Calc
    Application.ScreenUpdating = ScrnUpd
    Application.DisplayAlerts = Alerts
    Unload Create_Reports_Form
    Unload Macro_Running_Form
    Sheets("List").Visible = False
    Debug.Print "Line: " & Erl & " Error No. " & Err & "  Desc: " & Err.Description
    MsgBox "An error occurred, exiting macro...", vbCritical, "Error!"
End If


End Sub

Display More

Participate now!

Share