I have been exploring the same question and have put together a workbook with
both Excel's built-in Query tables using Data>GetExtenalData and the vba
method using ADO language.
The code for the former was pretty easy to generate using the Recorder, so I
won't expand on that.
Since the ADO code took considerable sniffing around and piecing together, I
will post it here to give you (and maybe others) a bit of a shortcut. The
code includes several alternatives which are commented. I often do this when
developing so I can later modify as needed. Each commented alternative has
been tested and works so just select your preference and uncomment it. As
usual you will want to adapt this to your specific needs.
Hope this helps.
Option Explicit
Sub GetDataWithADO()
''''''''''''''''''''''''''
' Purpose: Extract data from a Database to Excel
' Setup: Excel Named Ranges: Field1 >> the upper left cell of the
extraction range
' dbName, dbPath, dbTable,
' FieldList >> a verticle list of fields from the db
' This allows the user to select a subset of
fields to extract
' Under development: An excel Criteria range which will allow the user to
enter
' criteria for the fields selected in the FieldList rng. The
Criteria range
' will be used to build the sql WHERE clause.
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim Field As ADODB.Field
Dim sProv As String, sDS As String, sCon As String, sTable As String,
sql As String
Dim i As Integer, j As Integer, k As Integer
Dim StartDate As Date, EndDate As Date
Dim ExtractFields As Range, sFields As String
Dim MSG As String
On Error GoTo ErrHndlr
Sheets("ADO").Activate
'''GET DATA SOURCE
sProv = "Provider=Microsoft.Jet.OLEDB.4.0;" ' (MS ACCESS)
sDS = "Data Source=" & Range("dbPath") & "\" & Range("dbName") & ";"
'Alternatives:
' sDS = "Data Source=" & ThisWorkbook.Path & "\dbTEST1.mdb;"
' sDS = "Data Source=J:\EXCEL FILES\MyDatabaseName.mdb;"
sCon = "" & sProv & sDS & ""
sTable = Range("dbTable") 'Name of Database Table
'''GET DATE RANGES
On Error Resume Next
StartDate = Range("D12")
EndDate = Range("E12")
If Err > 0 Then
MsgBox "The Date ranges are invalid. Check the data type.",
vbOKOnly, "ERROR: "
Exit Sub
End If
On Error GoTo ErrHndlr
'''CLEAR OLD FIELDS
Range(Range("Field1"), Cells(Range("Field1").Row,
256).End(xlToLeft)).ClearContents
'''GET FIELD STRING
i = Application.CountA(Sheets("Sheet1").Range("FieldList"))
Set ExtractFields = Range(Range("Field1"), Range("Field1").Offset(0, i -
1))
ExtractFields = Application.Transpose(Sheets("Sheet1").Range("FieldList"))
For j = 1 To i
sFields = sFields & ", " & ExtractFields(j)
Next j
''' get rid of the first ","
sFields = Mid(sFields, 3)
''' CLEAR OLD DATA
Sheets("ADO").Range("Field1").CurrentRegion.Offset(1, 0).Clear
'''Create the SQL STRING
''' for DATE TYPE
sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((DOB) Between #1/1/90# And #1/1/93#) AND
((Lname)Like""B%"") AND ((City)Like""S%""))"
'Alternatives for Date fields:
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((DOB) >= #1/1/90#))"
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((DOB) >= #" & Range("D12") & "#))"
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((DOB) Between #" & Range("D12") & "# And #" & Range("E12")
& "#))"
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((DOB) Between #" & StartDate & "# And #" & EndDate & "#))"
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((DOB) Between #1/1/90# And #1/1/93#))"
''''''''''''''''''''''''''''''''''''''''
'Alternatives FOR TEXT STRING fields
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((Lname)Like""B%""))"
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((Lname)=""Jones""))"
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((Lname) Between """ & First & """ And """ & Last & """))"
' sql = "Select " & sFields & _
" From " & sTable & _
" WHERE (((Lname) Between ""Ba"" And ""N""))"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' OPEN THE CONNECTION
cn.Open sCon
'''OPEN THE RECORDSET
rs.CursorLocation = adUseClient
'this allows the RecordCount property to work
'when the db is on the client side
rs.Open sql, cn
'''COPY RECORDSET INTO XL RANGE
''First check to see if there is room
If rs.RecordCount > 65400 Then 'adj as desired
MSG = "The Number of Records Found: " & rs1.RecordCount & vbCrLf
MSG = MSG & "Exceeds the limit of this worksheet."
MsgBox MSG, vbOKOnly, "TOO MANY RECORDS: ADJUST THE SEARCH CRITERIA"
Exit Sub
End If
''Dump the recordset
Sheets("ADO").Range("Field1").Offset(1, 0).CopyFromRecordset rs1
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''FORMAT DATE FIELDS - THESE DON'T DOWNLOAD IN DATE FORMAT
k = 1
For Each Field In rs.Fields
If Field.Type = adDate Then
ExtractFields(k).EntireColumn.NumberFormat = "mm/dd/yy"
End If
k = k + 1
Next Field
''''''''''''''''''''''''''''''''''''''''''''''''
''' CLOSE
Tidy:
Set cn = Nothing
Set rs = Nothing
Set ExtractFields = Nothing
Set Field = Nothing
Exit Sub
ErrHndlr:
MsgBox "UNABLE TO COMPLETE THE SEARCH.", vbOKOnly, "ERROR:"
GoTo Tidy
End Sub
