Run-time error '2147417848 (80010108)' Automation Error - HELP!

[K1600]

Hi, I am having issues where I am getting the above run-time error but can't seem to work out where I am going wrong. Other searches of the error seem to suggest a link to Internet Explorer but my code has no links with IE at all.

The issues is linked to my 'Change Workplace' UserForm, if this is accessed from my Main User Console UserForm then the form works without issue irrespective of options selected. If a user opens one of three other UserForms and enters their unique PIN there is an 'After Update' code that having obtained the users details from another spreadsheet checks is the users workplace is set to "X" and if so it closes the current UserForm and opens the Change Workplace UserForm. This happens without issue and if the user changes their workplace to one in the dropdown list on the UserForm then there is no issues. However, if the user clicks 'Cancel', this drops them back to the User Console UserForm (which it should) but if they then click 'Exit' on here which should then close Excel, I get the run-time error. All functions work correctly on their own, it's only when a user is pushed to the Change Workplace UserForm from one of the three other UserForms, one being the 'Void' UserForm which I have used as the example below.

Code which checks for location "X" and then opens Change Workplace UserForm:

Private Sub DDPIN_AfterUpdate()

'Ensures PIN entered is no more than 5 digits
If Len(DDPIN.value) > 5 Then
    MsgBox "Please enter a valid PIN.", vbCritical, "Returns"
    Exit Sub
End If

'Ensures PIN entered is no less than 3 digits
If Len(DDPIN.value) < 3 Then
    MsgBox "Please enter a valid PIN.", vbCritical, "Returns"
    Exit Sub
End If

'Checks if a PIN has been entered with a leading zero
If Left(DDPIN.value, 1) = "0" Then
    MsgBox "You have entered a PIN starting with a zero." & vbCr & _
        "" & vbCr & _
        "If you have a 3 or 4 digit PIN, drop the leading zero(s) and retry.", vbCritical, "Returns"
    DDPIN.value = ""
    Exit Sub
End If

Application.ScreenUpdating = False    'Stops screen from showing during check

'Check to see if PIN exists
Dim wbk As Workbook
Set wbk = Workbooks.Open("FILEPATH_AND_NAME.xlsx", ReadOnly:=True)

If WorksheetFunction.CountIf(wbk.Sheets("Authorised Users").Range("A:A"), Me.DDPIN.value) = 0 Then
    MsgBox "Incorrect PIN Entered.", vbCritical, "Returns"
    wbk.Close SaveChanges:=False
    Me.DDSurname = ""
    Me.DDDivision = ""
    Me.DDPIN.value = ""
Exit Sub
End If

'Lookup values based on first control
With Me
'Checks data range for PIN. "Lookup" is the named range in the Authorised Users sheet
.DDSurname = Application.WorksheetFunction.VLookup(CLng(Me.DDPIN), wbk.Sheets("Authorised Users").Range("Lookup"), 3, 0)
.DDDivision = Application.WorksheetFunction.VLookup(CLng(Me.DDPIN), wbk.Sheets("Authorised Users").Range("Lookup"), 4, 0)

End With

wbk.Close SaveChanges:=False
Application.Visible = False
Application.ScreenUpdating = True   'Re-enables ScreenUpdating

'Forces user shown as "X" to update their location
    If DDDivision.value = "X" Then
        MsgBox "Please update your location from 'X' before you can continue." & vbCr & _
            "" & vbCr & _
            "Pressing OK will take you to the 'Change Workplace' page. Once updated you can continue in the normal way.", vbCritical, "Returns"
        Unload UsrFrmVoid
        'Centres new UserForm on screen
        With UsrFrmChangeWorkplace
            .StartUpPosition = 0
            .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
            .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
            .Show
        End With
    End If

End Sub

The code on the 'Cancel' button on the Change Workplace UserForm is:

Private Sub CMD_Cancel_Click()
'Close the userform
Unload Me
'Re-Load the User Form in centre of screen
    With UsrFrmUserConsole
        .StartUpPosition = 0
        .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
        .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
        .Show
    End With
End Sub

The code on the 'Exit' button on the User Console UserForm is:

Private Sub CMD_Close_Click()
Unload Me
Application.Visible = True
' Checks to see if other workbooks are open and if so only closes current workbook, if nothing else open, closes Excel
    If Workbooks.Count < 2 Then
    Application.Quit
    Else
    ActiveWorkbook.Close SaveChanges:=False
    End If

End Sub

Hopefully this makes sense and any help would be greatly appreciated.

Thanks in advance.

 

[Worf]

Hi

Were you able to solve this one?

 

[K1600]

Hi

Were you able to solve this one?

Hi,

Unfortunately not.

 

[Worf]

This seems to work:

Private Sub DDPIN_AfterUpdate()
'Ensures PIN entered is no more than 5 digits
If Len(DDPin.Value) > 5 Then
    MsgBox "Please enter a valid PIN.", vbCritical, "Returns"
    Exit Sub
End If
'Ensures PIN entered is no less than 3 digits
If Len(DDPin.Value) < 3 Then
    MsgBox "Please enter a valid PIN.", vbCritical, "Returns"
    Exit Sub
End If
'Checks if a PIN has been entered with a leading zero
If Left(DDPin.Value, 1) = "0" Then
    MsgBox "You have entered a PIN starting with a zero." & vbCr & _
        "" & vbCr & _
        "If you have a 3 or 4 digit PIN, drop the leading zero(s) and retry.", vbCritical, "Returns"
    DDPin.Value = ""
    Exit Sub
End If
Dim wbk As Workbook
Set wbk = Workbooks.Open("c:\test\macro3.xlsm", ReadOnly:=True)
If WorksheetFunction.CountIf(wbk.Sheets("Authorised Users").Range("A:A"), Me.DDPin.Value) = 0 Then
    MsgBox "Incorrect PIN Entered.", vbCritical, "Returns"
    wbk.Close SaveChanges:=False
    Me.DDSurname = ""
    Me.DDDivision = ""
    Me.DDPin.Value = ""
Exit Sub
End If
'Lookup values based on first control
With Me
'Checks data range for PIN. "Lookup" is the named range in the Authorised Users sheet
.DDSurname = Application.WorksheetFunction.VLookup(CLng(Me.DDPin), wbk.Sheets("Authorised Users").Range("Lookup"), 3, 0)
.DDDivision = Application.WorksheetFunction.VLookup(CLng(Me.DDPin), wbk.Sheets("Authorised Users").Range("Lookup"), 4, 0)
End With
wbk.Close SaveChanges:=False
Set wbk = Nothing
Application.ScreenUpdating = True   'Re-enables ScreenUpdating
'Forces user shown as "X" to update their location
    If DDDivision.Value = "X" Then
        MsgBox "Please update your location from 'X' before you can continue." & vbCr & _
            "" & vbCr & _
            "Pressing OK will take you to the 'Change Workplace' page." & _
            " Once updated you can continue in the normal way.", vbCritical, "Returns"
         Void.Hide
        With ChangeWorkplace
            .StartUpPosition = 0
            .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
            .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
            .Show
        End With
    End If
MsgBox perm, , "Close Excel?"
UserConsole.Hide
ChangeWorkplace.Hide
ThisWorkbook.Save
Me.Hide
Application.OnTime Now, "close_routine"
End Sub

'Workplace
Private Sub CMD_Cancel_Click()
Me.Hide
'Re-Load the User Form in centre of screen
    With UserConsole
        .StartUpPosition = 0
        .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
        .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
        .Show
    End With
End Sub

' UserConsole
Private Sub CMD_Close_Click()
Me.Hide
perm = False
Application.Visible = True
If Workbooks.Count < 2 Then
    perm = True
Else
    perm = False
End If
End Sub

' standard module
Public perm As Boolean
Sub close_routine()
MsgBox "closing"
If perm Then
    With Application
        .DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:="c:\test\newname.xlsm"
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .Quit
    End With
Else
    ThisWorkbook.Close True
End If
End Sub