打开/关闭 ADO 连接

Question

我正在尝试将数据从 Access 导入 Excel。 Access 表中有四列：Date、Time、Tank、Comments。在导入 Time 和 Tank 列时，我根据日期对它们进行排序。此外，我单独导入它们，这样我就可以交换列顺序表单时间、坦克到坦克、时间。在编程中，我必须为此关闭并打开 ADO 连接。我想通过避免关闭连接并再次打开它来提高程序的效率。有什么建议/解决方案吗？谢谢。

Sub ADOImportFromAccessTable()
Dim DBFullName As String
Dim TankRange As Range
Dim TimeRange As Range
Dim RpDate
Dim TankSelect As String
Dim TimeSelect As String
Dim r As Long

DBFullName = "U:\Night Sup\Production Report 2003 New Ver 5-28-10_KA.mdb"
Worksheets("TankHours").Activate
Set TankRange = Range("C5")
Set TimeRange = Range("D5")
Set RpDate = Range("B2").Cells


Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer
    Set TankRange = TankRange.Cells(1, 1)
    Set TimeRange = TimeRange.Cells(1, 1)
    ' open the database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
        "U:\Night Sup\Production Report 2003 New Ver 5-28-10_KA.mdb" & ";"
    Set rs = New ADODB.Recordset

    With rs
    ' open the recordset
    ' filter rows based on date
    TankSelect = "SELECT u.Tank" & vbCrLf & _
    "FROM UnitOneRouting AS u" & vbCrLf & _
    "WHERE u.Date = " & Format(RpDate, "\#yyyy-m-d\#") & vbCrLf & _
    "ORDER BY u.Time, u.Tank;"

    .Open TankSelect, cn, adOpenStatic, adLockOptimistic, adCmdText

     TankRange.CopyFromRecordset rs
     'End With
     'rs.Close
   ' Set rs = Nothing
    cn.Close
   ' Set cn = Nothing


   ' Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
        "U:\Night Sup\Production Report 2003 New Ver 5-28-10_KA.mdb" & ";"
    'Set rs = New ADODB.Recordset
    ' With rs
    '' open the recordset
    '' filter rows based on date
    TimeSelect = "SELECT u.Time" & vbCrLf & _
    "FROM UnitOneRouting AS u" & vbCrLf & _
    "WHERE u.Date = " & Format(RpDate, "\#yyyy-m-d\#") & vbCrLf & _
    "ORDER BY u.Time, u.Tank;"

    .Open TimeSelect, cn, adOpenStatic, adLockOptimistic, adCmdText

     TimeRange.CopyFromRecordset rs

    End With
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing


End Sub

Answer 1

记录集列按您的Select 语句的顺序返回。因此，如果您希望 Tank 排在第一位，请先将其列出，如下所示：TankSelect = "SELECT u.Tank, u.Time... 其余代码

简单示例：

Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
    "U:\Night Sup\Production Report 2003 New Ver 5-28-10_KA.mdb" & ";"

Set rs = New ADODB.Recordset

TankSelect = "SELECT u.Tank, u.Time" & vbCrLf & _
             "FROM UnitOneRouting AS u" & vbCrLf & _
             "WHERE u.Date = " & Format(RpDate, "\#yyyy-m-d\#") & vbCrLf & _
             "ORDER BY u.Tank;"

rs.Open TankSelect, cn, adOpenStatic, adLockOptimistic, adCmdText

TankRange.CopyFromRecordset rs

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

---

您还可以使用GetRows 将特定字段返回到数组。这也允许您操作您的结果，而无需对数据库进行任何其他调用。这是一个例子：

Dim FieldsToSelect(0 To 1) As Variant
FieldsToSelect(0) = "TankVal"
FieldsToSelect(1) = "TimeVal"

With rs
    TankSelect = "SELECT u.Tank AS TankVal, u.Time AS TimeVal" & vbCrLf & _
                 "FROM UnitOneRouting AS u" & vbCrLf & _
                 "WHERE u.Date = " & Format(RpDate, "\#yyyy-m-d\#") & vbCrLf & _
                 "ORDER BY u.Tank;"

    .Open TankSelect, cn, adOpenStatic, adLockOptimistic, adCmdText

    ResultsArray = .GetRows(Fields:=FieldsToSelect)
End With

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

'Do what you want with array of results

ResultsArray 将按照您在FieldsToSelect 中声明的顺序列出字段结果

---

当然，另一种选择是循环遍历您的记录集并将特定字段输出到特定单元格中。

Answer 2

Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer
    Set TankRange = TankRange.Cells(1, 1)
    Set TimeRange = TimeRange.Cells(1, 1)
    ' open the database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
        "U:\Night Sup\Production Report 2003 New Ver 5-28-10_KA.mdb" & ";"
    Set rs = New ADODB.Recordset

    With rs
    ' open the recordset
    ' filter rows based on date
    TankSelect = "SELECT u.Tank" & vbCrLf & _
    "FROM UnitOneRouting AS u" & vbCrLf & _
    "WHERE u.Date = " & Format(RpDate, "\#yyyy-m-d\#") & vbCrLf & _
    "ORDER BY u.Time, u.Tank;"

    .Open TankSelect, cn, adOpenStatic, adLockOptimistic, adCmdText

     TankRange.CopyFromRecordset rs
     'End With
     'rs.Close
   ' Set rs = Nothing

    cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
        "U:\Night Sup\Production Report 2003 New Ver 5-28-10_KA.mdb" & ";"
    'Set rs = New ADODB.Recordset
    ' With rs
    '' open the recordset
    '' filter rows based on date
    TimeSelect = "SELECT u.Time" & vbCrLf & _
    "FROM UnitOneRouting AS u" & vbCrLf & _
    "WHERE u.Date = " & Format(RpDate, "\#yyyy-m-d\#") & vbCrLf & _
    "ORDER BY u.Time, u.Tank;"

    .Open TimeSelect, cn, adOpenStatic, adLockOptimistic, adCmdText

     TimeRange.CopyFromRecordset rs

    End With
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing   

End Sub

我还没有对此进行测试，但我所做的只是删除了 cn.Close 并对其进行了更改，因此它只会更改连接字符串（不确定这是否是正确的属性，但我确定有一个属性为了它）。然后我把它放在最后。

Answer 3

在您的示例中可以改进几处：
1) 您无需关闭连接即可运行另一个查询（打开不同的记录集），
2）您使用相同的where条件从同一张表中选择两次，我会更好 在一个查询中同时选择两个单元格并一次填充两个单元格，
3) 不使用 SQL 参数是一种不好的编程习惯， 示例

Sub ADOImportFromAccessTable()

    Dim DBFullName As String
    Dim TankRange As Range
    Dim Cmd1 As ADODB.Command
    Dim Param1 As ADODB.Parameter
    Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer

    DBFullName = "U:\Night Sup\Production Report 2003 New Ver 5-28-10_KA.mdb"
    Worksheets("TankHours").Activate
    Set TankRange = Range("C5")

    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBFullName & ";"

    Set Cmd1 = New ADODB.Command

    Cmd1.CommandText = "select Tank, Time from UnitOneRouting where Date = ?"
    Cmd1.CommandType = adCmdText
    Cmd1.ActiveConnection = cn

    Set Param1 = Cmd1.CreateParameter("date1", adDate, adParamInput, , Range("B2").Value)
    Cmd1.Parameters.Append Param1

    Set rs = Cmd1.Execute()

    TankRange.CopyFromRecordset rs, 1 ' copy just one row, ignore rest if there are more

    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing

End Sub