Open/Close ADO Connection

问题

I am trying to import data from Access to Excel. There are four columns in the Access table: Date, Time, Tank, Comments. On importing the Time and Tank columns, I sort them based on date. Additionally, I import them separately so I can swap the column order form Time, Tank to Tank, Time. In the programming I have to close and open the ADO connection for that. I want to make the program more efficient by avoiding closing the connection and having to open it again. Any suggestions/solutions? Thanks.

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

回答1:

Recordset columns are returned in the order of your Select statement. So if you want Tank to be first then list it first like this: TankSelect = "SELECT u.Tank, u.Time... rest of your code

Simple example:

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

You can also return specific fields to an array by using GetRows. This also allows you to manipulate your results without having to make any other call to the database. Here is an example:

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

The ResultsArray will list the field results in the order that you declare them in FieldsToSelect

Of course, another option is to just loop through your recordset and output the specific fields into specific cells.

回答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

I haven't tested this, but all I did was remove the cn.Close and changed it, so it will just change the connection string (not sure if that is the right property, but I'm sure there is aproperty for it). Then I left the close it at the end.

回答3:

Several things can be improved in your example:
1) You don't need to close connection to run another query (open different recordset),
2) You select from the same table using the same where condition twice, I would be much better to select both in one query and populate two cells in one go,
3) Not using SQL parameters is a bad programming practice, Example

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

来源：https://stackoverflow.com/questions/26105927/open-close-ado-connection

标签

vba

excel-vba

ado

excel