Question

这是我的完整代码。我能够运行一次代码并将记录集导出到excel，但我不能在第二次执行不同的操作。

看起来在记录集关闭一次后，它不会再次打开。当我第二次搜索它时，它给我上面的错误 3704 。

基本上我有一个带有三个文本框的表单来搜索数据库，然后将记录集导出为excel。

由于我不是一位经验丰富的程序员，我可能会遗漏一些简单的事情。

Option Compare Database

Private Sub search_Click()

    Dim cn As Object

    Dim rs As ADODB.Recordset

    Dim strSql As String


    Dim strConnection As String

    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object

    Set cn = CreateObject("ADODB.Connection")

    Set rs = New ADODB.Recordset


    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=C:\Users\e3017764\Desktop\Master.accdb"

    cn.Open strConnection


    If (skill.Value = "" And location.Value = "" And project.Value = "") Then

        MsgBox "Please Enter Atleast one criteria"


    ElseIf (skill.Value <> "" And location.Value = "" And project.Value = "") Then

        strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "'"

        rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic


    ElseIf (skill.Value = "" And location.Value = "" And project.Value <> "") Then

        strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE Project = '" & project.Value & "'"

        rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic


    ElseIf (skill.Value = "" And location.Value <> "" And project.Value = "") Then

        strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE Location = '" & location.Value & "'"

        rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic


    ElseIf (skill.Value <> "" And project.Value <> "" And location.Value = "") Then

        strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "' AND Project = '" & project.Value & "'"

        rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic


    ElseIf (skill.Value <> "" And project.Value = "" And location.Value <> "") Then

        strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "' AND Location = '" & location.Value & "'"

        rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic


    ElseIf (skill.Value = "" And project.Value <> "" And location.Value <> "") Then

        strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE Project = '" & project.Value & "' AND Location = '" & location.Value & "'"

        rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic


    ElseIf (skill.Value <> "" And project.Value <> "" And location.Value <> "") Then

        rs.Open

        strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "' AND Project = '" & project.Value & "' AND Location = '" & location.Value & "'"

        rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic

    End If

    MsgBox " Total Records Matched " & rs.RecordCount

    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("Sheet1")


    xlApp.Visible = True
    xlApp.UserControl = True

    xlWs.Cells(1, 1).Value = "E Code"
    xlWs.Cells(1, 2).Value = "Name"
    xlWs.Cells(1, 3).Value = "Project"
    xlWs.Cells(1, 4).Value = "Location"

    xlWs.Cells(2, 1).CopyFromRecordset rs

    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit


    rs.Close
    Set rs = Nothing

    cn.Close
    Set cn = Nothing

End Sub

Answer 1

我同意@Sobigen，第二次你的IF没有一个是真的。也许。无论如何，我认为如果你简化了IF，你可能会更快地看到答案。这是一个需要重写的重写

Private Sub search_Click()

    Dim rs As ADODB.Recordset
    Dim sSql As String
    Dim aWhere() As String
    Dim lWhereCnt As Long
    Dim xlApp As Object
    Dim xlWs As Object

    'This never changes, so make it a constant
    Const sSELECT As String = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE "

    'put each piece of your where clause in an array
    If Len(Me.skill.Value) > 0 Then
        lWhereCnt = lWhereCnt + 1
        ReDim Preserve aWhere(1 To lWhereCnt)
        aWhere(lWhereCnt) = "[Primary Skills] = '" & Me.skill.Value & "'"
    End If

    If Len(Me.location.Value) > 0 Then
        lWhereCnt = lWhereCnt + 1
        ReDim Preserve aWhere(1 To lWhereCnt)
        aWhere(lWhereCnt) = "[Location] = '" & Me.location.Value & "'"
    End If

    If Len(Me.project.Value) > 0 Then
        lWhereCnt = lWhereCnt + 1
        ReDim Preserve aWhere(1 To lWhereCnt)
        aWhere(lWhereCnt) = "[Project] = '" & Me.project.Value & "'"
    End If

    'If there's at least one criterion
    If lWhereCnt > 0 Then

        'build the sql and execute it
        sSql = sSELECT & Join(aWhere, " And ") & ";"
        Set rs = CurrentProject.Connection.Execute(sSql)

        'if at least one record is returned put it in excel
        If Not rs.BOF And Not rs.EOF Then
            Set xlApp = CreateObject("Excel.Application")
            Set xlWs = xlApp.Workbooks.Add.worksheets(1)

            xlApp.Visible = True
            xlApp.UserControl = True

            xlWs.Cells(1, 1).Resize(1, 4).Value = Split("E Code,Name,Project,Location", ",")
            xlWs.Cells(2, 1).CopyFromRecordset rs

            xlApp.Selection.CurrentRegion.Columns.AutoFit
            xlApp.Selection.CurrentRegion.Rows.AutoFit


            rs.Close
            Set rs = Nothing
        Else
            'if no records are return, take a look at the sql statement to see why
            MsgBox sSql
        End If

    Else
        MsgBox "Please Enter Atleast one criteria"
    End If

End Sub

关闭对象时不允许操作

1 个答案: