Question

我正在尝试简化将数据提取到多个工作表的工作簿。提取使用用户名和密码，因此我希望登录部分保存在模块中，而不是在每个工作表上多次定义。

将原始工作代码移动到模块后，我得到一个错误424对象。我在这里搜索了一下，无法找到任何指向我错误的方法。

' This extracts all requirements
Sub Extract()

' declared variables
Dim iRow As Integer
Dim objReq As Variant
Const iconStartRow As Integer = 4
Dim UN As String
UN = Sheet01.Range("Username").Value
Dim PW As String
PW = Sheet01.Range("Password").Value

'Run the Error handler "ErrHandler" when an unknown error occurs.
On Error GoTo Errhandler

Application.ScreenUpdating = False              ' stop screen from updating while extract happening
Sheet02.Unprotect Password:="xx"                ' remove the worksheet protection.
Application.Calculation = xlCalculationManual   ' turn off automatic calculation to speed up extract

    ' Update Excel Status Bar
    Application.StatusBar = "Logging in..."

    **' if we have the client set up, we can create a new connection
    connect

    ' login or return login error to user
    On Error GoTo LoginError
    QCCon.ConnectProject Sheet01.Range("Project").Value, UN, PW
    On Error GoTo 0**


    ' Update Excel Status Bar
    Application.StatusBar = "Extracting data..."

    ' set filters for extracting requirements
    Set QCReqFac = QCCon.ReqFactory
    Set QCFilter = QCReqFac.Filter
    QCFilter.Filter("RQ_TYPE_ID") = "Not (Group or Folder)"

    ' set cursor to start at row 4
    iRow = iconStartRow

    ' clear all existing data from worksheet
    Sheets("Requirements").Select
    Range(Cells(iRow, 1), Cells(1000, 11)).ClearContents

    ' extract the content to Excel
    For Each objReq In QCFilter.NewList
        Cells(iRow, 1).Value = objReq.Field("RQ_USER_03")         'Business Requirement ID
        Cells(iRow, 2).Value = objReq.Field("RQ_TYPE_ID")         'Requirement Type
        Cells(iRow, 3).Value = objReq.Field("RQ_USER_05")         'Category
        Cells(iRow, 4).Value = objReq.Field("RQ_REQ_NAME")        'Requirement Name
        Cells(iRow, 5).Value = objReq.Field("RQ_REQ_COMMENT")     'Requirement Description
        Cells(iRow, 6).Value = objReq.Field("RQ_USER_01")         'Business Priority
        Cells(iRow, 7).Value = objReq.Field("RQ_USER_04")         'Business Area
        Cells(iRow, 8).Value = objReq.Field("RQ_USER_02")         'Business Owner
        Cells(iRow, 9).Value = objReq.Field("RQ_DEV_COMMENTS")    'Notes
        Cells(iRow, 10).Value = objReq.Field("RQ_USER_06")        'Delivery Scope
        Cells(iRow, 11).Value = objReq.Field("RQ_REQ_STATUS")     'Test Status
        iRow = iRow + 1
    Next

    ' restore default statusbar text
    Application.StatusBar = False
    Application.DisplayStatusBar = True

    ' update cell K2 with the date and time of when the last extract was run
    ExtractTime

    ' release QC connection
    If QCCon.Connected Then
       If QCCon.ProjectConnected Then
          QCCon.DisconnectProject
       End If
       QCCon.ReleaseConnection
    End If
    Set QCCon = Nothing
End If

' sort the extract
Sort

' set calculation back to automatic, turn screen updating back on and protect the worksheet
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sheet02.Protect Password:="xx", AllowFormattingRows:=True, AllowFiltering:=True, UserInterfaceOnly:=True
Exit Sub
' code to handle an unknown error. The error description should be enough to start debugging.
Errhandler:
Application.StatusBar = False
Application.DisplayStatusBar = True
Sheet02.Protect Password:="xx", AllowFormattingRows:=True, AllowFiltering:=True, UserInterfaceOnly:=True
Application.ScreenUpdating = True
MsgBox "Error " & Err.Number & ": " & Err.Description
Exit Sub
End Sub

执行初始连接的代码位于

之下

**Sub QC_connect()

Dim sconQCURL As String
sconQCURL = "http://xx.xx:xxxx/xxxxx"        

Set QCCon = New TDConnection
QCCon.InitConnection sconQCURL, Sheet01.Range("QC_Domain").Value
End Sub**

我相信我需要在星号之间移动所有位，但是当我这样做时只是错误。

非常感谢任何帮助。

将工作表代码移动到模块后，Excel VBA错误424

0 个答案: