执行excel宏时崩溃excel

Question

我正在使用下面的代码行运行一个excel宏，但是当光标进入Set objADMProjBO = objSiebApp.GetBusObject("EMT Project")语句时，它会崩溃excel并停止程序。有人可以帮助我如何运行该程序而不会崩溃excel。

Sub MakeADMProject()
Application.ScreenUpdating = False
On Error GoTo err_MakeADMProject
    Dim ParRowID As String
    Dim RelCounter, i, j As Integer
    Dim FilterArr() As String
    Dim ADMDataType As String

    ReleaseNumber = ActiveSheet.Cells(2, 1)
    RelCounter = 1

    If Login("DEV", "user", "passsword") = False Then
            MsgBox "Error while logging into Siebel Application", vbCritical, "Login Error!"
            End
    End If
    'Set Inputs = objSiebApp.NewPropertySet
    'Set Outputs = objSiebApp.NewPropertySet

    If InitialiseBOBC = False Then
        MsgBox "Error while initialising BO & BC", vbCritical, "BO BC Initialization!"
       Application.Quit
      End
    End If
    Set objADMProjParBC = objADMProjBO.GetBusComp("EMT Project")

    With objADMProjParBC
            .ActivateField "Name"
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            .ActivateField "Export Flag"
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            .ActivateField "Allow Session Updates Flag"
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            .NewRecord 1
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            ParRowID = .GetFieldValue("Id")
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

SaveRecord:
            .SetFieldValue "Name", ReleaseNumber
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            .SetFieldValue "Export Flag", "Y"
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            .SetFieldValue "Allow Session Updates Flag", "Y"
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            .WriteRecord
            If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

            For i = 2 To GetRange(ThisWorkbook.Sheets("ADM"), 1)

                FilterArr = Split(ActiveSheet.Cells(i, 3), vbCrLf)

                For j = 0 To UBound(FilterArr)

                    With objADMProjChiBC

                        .ActivateField "Data Type Name"
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

                        .ActivateField "Name"
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

                        .ActivateField "Data Filter"
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

                        .NewRecord 1
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject


                        ADMDataType = GetADMDataType(Mid(LCase(ActiveSheet.Cells(i, 2)), 1, InStr(ActiveSheet.Cells(i, 2), ".") - 1))

                        .SetFieldValue "Data Type Name", ADMDataType
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

                        .SetFieldValue "Name", ADMDataType & "_" & CStr(j + 1)
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

                        .SetFieldValue "Data Filter", FilterArr(j)
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

                        .WriteRecord
                        If objSiebApp.GetLastErrText <> "" Then GoTo err_MakeADMProject

                    End With
                Next j
            Next i


            .InvokeMethod "Activate", Inputs
    End With
    MsgBox "Deployment Project Created", vbOKOnly, "INFO"
    Exit Sub
err_MakeADMProject:
    'ActiveSheet.Cells(i, 2) = objSiebApp.GetLastErrText
    'GoTo next_row
    If InStr(objSiebApp.GetLastErrText, "The same values for ") Then
        ReleaseNumber = ReleaseNumber & "_" & RelCounter
        For i = 2 To GetRange(ThisWorkbook.Sheets("ADM"), 1)
            ActiveSheet.Cells(i, 1) = ReleaseNumber
        Next i
        RelCounter = RelCounter + 1
        Err.Clear
        GoTo SaveRecord
    End If
    Set objADMProjBO = Nothing
    Set objADMProjParBC = Nothing
    Set objADMProjChiBC = Nothing
    objSiebApp.Logoff
    Set objSiebApp = Nothing

    If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description
    Application.ScreenUpdating = True
End Sub

Function InitialiseBOBC() As Boolean
On Error GoTo err_InitialiseBOBC

    InitialiseBOBC = False

    Set objADMProjBO = objSiebApp.GetBusObject("EMT Project")
    If objSiebApp.GetLastErrText <> "" Then GoTo err_InitialiseBOBC

    Set objADMProjParBC = objADMProjBO.GetBusComp("EMT Project")
    If objSiebApp.GetLastErrText <> "" Then GoTo err_InitialiseBOBC

    Set objADMProjChiBC = objADMProjBO.GetBusComp("EMT Project Item")
    If objSiebApp.GetLastErrText <> "" Then GoTo err_InitialiseBOBC

    Set objADMSessBO = objSiebApp.GetBusObject("EMT Session")
    If objSiebApp.GetLastErrText <> "" Then GoTo err_InitialiseBOBC

    Set objADMSessParBC = objADMSessBO.GetBusComp("EMT Session")
    If objSiebApp.GetLastErrText <> "" Then GoTo err_InitialiseBOBC

    Set objADMSessChiBC = objADMSessBO.GetBusComp("EMT Session Item")
    If objSiebApp.GetLastErrText <> "" Then GoTo err_InitialiseBOBC

    InitialiseBOBC = True

    Exit Function

err_InitialiseBOBC:
    InitialiseBOBC = False
End Function