From ExcelExperts.com
VBA code to handle Access Imports and Query: 
Paste the following code in a general module
Public g_objConnection As ADODB.Connection
Public Const gc_strDBPath As String = "C:\Test.mdb"
Function blnConnectDatabase(strPath As String, strDBPass As String) As Boolean
' If blnFileExists(strPath) = False Then
' GoTo ErrH
' Exit Function
' End If
Set g_objConnection = New ADODB.Connection
On Error GoTo ErrH
g_objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
strPath & ";Jet OLEDB:Database Password=" & strDBPass & ";"
On Error GoTo 0
blnConnectDatabase = True
GoTo ExitH
ErrH:
blnConnectDatabase = False
Set g_objConnection = Nothing
ExitH:
Application.StatusBar = False
End Function
Function blnTableExistsInDB(strTableName As String) As Boolean
Dim rst As ADODB.Recordset
Dim strTbl As String
strTbl = strTableName
Call blnConnectDB
Set rst = g_objConnection.OpenSchema(adSchemaTables)
If Left(strTbl, 1) = "[" And Right(strTbl, 1) = "]" Then
strTbl = Mid(strTbl, 2, Len(strTbl) - 2)
End If
rst.Filter = "TABLE_TYPE='TABLE' and TABLE_NAME='" & strTbl & "'"
On Error Resume Next
blnTableExistsInDB = (UCase(rst.Fields("TABLE_NAME").Value) = UCase(strTbl))
On Error GoTo 0
If Err.Number <> 0 Then blnTableExistsInDB = False
Set rst = Nothing
End Function
Function ExecuteDBQuery(strQuery As String, Optional rngTarget As Range, Optional blnHeader As Boolean) As ADODB.Recordset
Dim objRecordset As ADODB.Recordset
Dim intColIndex As Integer
Dim lngRowOffset As Long
On Error GoTo ErrH
Call blnConnectDB
If Not rngTarget Is Nothing Then
Set rngTarget = rngTarget.Cells(1, 1)
End If
Set objRecordset = New ADODB.Recordset
With objRecordset
.CursorLocation = adUseClient
'.Open strQuery, g_objConnection, adOpenForwardOnly, adLockReadOnly ', adCmdText
.Open strQuery, g_objConnection, adOpenDynamic, adLockOptimistic ', adCmdText
If Not rngTarget Is Nothing Then
If blnHeader = True Then
For intColIndex = 0 To objRecordset.Fields.Count - 1 'field names
rngTarget.Cells(1, intColIndex + 1).NumberFormat = "@"
rngTarget.Cells(1, intColIndex + 1).Value = .Fields(intColIndex).Name
rngTarget.Cells(1, intColIndex + 1).Font.Bold = True
Next intColIndex
lngRowOffset = 1
Else 'Without field names
lngRowOffset = 0
End If
If Application.Version < 12 And .RecordCount + rngTarget.Cells(lngRowOffset + 1, 1).Row > 65535 Then
MsgBox "Records upto row number 65535 can be accommodated. Rest will be ignored.", vbInformation, "Import"
ElseIf Application.Version >= 12 And objRecordset.RecordCount + rngTarget.Cells(lngRowOffset + 1, 1).Row > 1048576 Then
MsgBox "Records upto row number 1048576 can be accommodated. Rest will be ignored.", vbInformation, "Import"
End If
rngTarget.Cells(lngRowOffset + 1, 1).CopyFromRecordset objRecordset ' the recordset data
End If
End With
Set ExecuteDBQuery = objRecordset
ErrH:
Set objRecordset = Nothing
If Err.Number <> 0 Then
'MsgBox Err.Description, vbCritical, "Error"
'MsgBox "Database Query Error"
End If
End Function
Sub DropTable(ParamArray strTableName() As Variant)
Dim x As Integer
For x = LBound(strTableName) To UBound(strTableName)
If blnTableExistsInDB(CStr(strTableName(x))) = True Then
Call ExecuteDBQuery("Drop Table " & CStr(strTableName(x)))
End If
Next x
End Sub
Function blnConnectDB() As Boolean
Dim blnCon As Boolean
blnCon = True
If g_objConnection Is Nothing Then
blnCon = blnConnectDatabase(gc_strDBPath, "")
ElseIf Not g_objConnection.State = 1 Then
blnCon = blnConnectDatabase(gc_strDBPath, "")
End If
blnConnectDB = blnCon
End Function
Sub CompactDB()
Dim lngRes As Long
Call CloseDB
lngRes = DatabaseCompact(gc_strDBPath)
If lngRes = 0 Then
'MsgBox "Succeeded in compacting database...", vbInformation
Else
'MsgBox Error(lngRes)
Application.StatusBar = "Unable to clean database..."
End If
End Sub
Function DatabaseCompact(strDBPath As String, Optional strDBPass As String = "") As Long
On Error GoTo ErrFailed
'Delete the existing temp database
If Len(Dir$(strDBPath & ".tmp")) Then
VBA.Kill strDBPath & ".tmp"
End If
With CreateObject("JRO.JetEngine")
If strDBPass = "" Then 'DB without password
.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ".tmp;Jet OLEDB:Encrypt Database=True"
Else 'Password protected db
.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ";Jet OLEDB:Database Password=" & strDBPass, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ".tmp;Jet OLEDB:Encrypt Database=True;Jet OLEDB:Database Password=" & strDBPass
End If
End With
On Error GoTo 0
VBA.Kill strDBPath 'Delete the existing database
Name strDBPath & ".tmp" As strDBPath 'Rename the compacted database
ErrFailed:
DatabaseCompact = Err.Number
End Function
Sub CloseDB()
If Not g_objConnection Is Nothing Then
If g_objConnection.State = 1 Then g_objConnection.Close
End If
Set g_objConnection = Nothing
End Sub
. Right now we will see, how it can introduce unparalleled flexibility in your models.
