Thread: Import Access Table contents with criteria.

Hi J

The code below seems to work and was tested. You will have to change several
items as indicated in the code.

hth
regards
John

Public Sub ImportFromAccess()

    ' * Save work book as Macro Workbook
    ' * Add General Module Alt-F11 - Insert Module
    ' * Tools -> References -> Microsoft ActiveX Data Objects 2.8
    ' * Tools -> References -> Microsoft ActiveX Data Recordset 2.8 Library
    ' * Tools -> References -> Microsoft ADO Ext 2.8 for DDL and Security
    ' * Paste this code into Module

    On Error GoTo EH_ImportFromAccess

    '------------------------------
    '   Objects
    '------------------------------
    Dim oCN As ADODB.Connection
    Dim oRS As ADODB.Recordset
    
    '------------------------------
    '   Properties
    '------------------------------
    Dim sProvider As String
    Dim sPath As String
    Dim sACCDBName As String
    Dim sWBName As String
    Dim sExtender As String
    Dim sDataSource As String
    Dim sCNString As String
    Dim sFullAccessFileName As String
    Dim sDoesFileExist As String
    Dim sTmp As String
    
    '------------------------------
    '   Counters
    '------------------------------
    Dim mlngRSRecCNT As Long
    Dim mlngRSFieldCNT As Long
    
    '------------------------------
    '   Misc
    '------------------------------
    Dim i As Integer
    Dim lng As Long
    
    '------------------------------
    '   SQL variables
    '------------------------------
    Dim sSQL As String

    '------------------------------
    '   WS Variables
    '------------------------------
    Dim sWS As String
    Dim oWS As Excel.Worksheet
    Dim oRng As Excel.Range

    '------------------------------
    '   Properties
    '------------------------------
    If Application.Version = 12# Then
        sProvider = "Microsoft.ACE.OLEDB.12.0;"
    Else
        sProvider = "Microsoft.Jet.OLEDB.4.0;"
    End If
    sPath = ThisWorkbook.Path & "\"         'Change to yours
    sACCDBName = "DBTarget.accdb"           'Change to yours
    sFullAccessFileName = sPath & sACCDBName
    sDoesFileExist = Dir(sFullAccessFileName)
    sExtender = vbNullString
    sDataSource = "Data Source = " & sPath & sACCDBName
    
    '------------------------------
    '   Does Access File Exist ?
    '------------------------------
    If Len(sDoesFileExist) < 2 Then
        sTmp = "The file named " & vbCrLf & vbCrLf
        sTmp = sTmp & sFullAccessFileName & vbCrLf & vbCrLf
        sTmp = sTmp & "does not exist ...................................... terminating"
        MsgBox sTmp, vbCritical, "Public Sub ImportFromAccess()"
        Exit Sub
    End If

    '------------------------------
    '   Connect To Access
    '------------------------------
    Set oCN = Nothing
    Set oCN = New ADODB.Connection
    With oCN
        .Provider = sProvider
        .ConnectionString = sDataSource
        .Open
    End With

    '------------------------------
    '   SQL Statement -
    '------------------------------
    '   Change to your Field Names
    '   Change to your Dates
    '   Change to your Table Name
    '------------------------------
    sSQL = "SELECT "
    sSQL = sSQL & " [Lastname], "
    sSQL = sSQL & " [Firstname], "
    sSQL = sSQL & " [MyRef], "
    sSQL = sSQL & " [MyDate] "
    sSQL = sSQL & " FROM "
    sSQL = sSQL & " [TargetTable] "
    sSQL = sSQL & " WHERE "
    sSQL = sSQL & " [MyDate] BETWEEN #12/27/2011# AND #2/27/2012#  "
    sSQL = sSQL & " ORDER BY "
    sSQL = sSQL & " [MyDate] "

    '------------------------------
    '   ADO Recordset
    '------------------------------
    Set oRS = Nothing
    Set oRS = New ADODB.Recordset
    With oRS
        .ActiveConnection = oCN
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockBatchOptimistic
        .Source = sSQL
        .Open
    End With
    
    '------------------------------
    '   Record Count and Field Count
    '------------------------------
    If Not oRS.BOF And Not oRS.EOF Then
        oRS.MoveLast
        oRS.MoveFirst
        mlngRSRecCNT = oRS.RecordCount
        mlngRSFieldCNT = oRS.Fields.Count
    Else
        '------------------------------
        '   No Records were returned
        '------------------------------
        sTmp = "The Recordset did not return any records " & vbCrLf & vbCrLf
        sTmp = sTmp & sSQL & vbCrLf & vbCrLf
        sTmp = sTmp & "Terminating ......"
        MsgBox sTmp, vbCritical, "Public Sub ImportFromAccess()"
        '--------------------------
        '   Kill Recordset Object
        '--------------------------
        On Error Resume Next
        If oRS.State <> 0 Then
            oRS.Close
            Set oRS = Nothing
        Else
            Set oRS = Nothing
        End If
        '--------------------------
        '   Kill Recordset Object
        '--------------------------
        If oCN.State <> 0 Then
            oCN.Close
            Set oCN = Nothing
        Else
            Set oCN = Nothing
        End If
        Exit Sub
    End If

    '--------------------------
    '   Write to a WS NAMED Target
    '--------------------------
    sWS = "Target"
    Set oWS = Sheets(sWS)
    With oWS
        .Activate
        .Cells.Delete
    End With
    
    '--------------------------
    '   Write FIELD Names
    '--------------------------
    For lng = 1 To mlngRSFieldCNT
        oWS.Rows(1).Columns(lng) = oRS.Fields(lng - 1).Name
    Next
    
    '--------------------------
    '   Write FIELD Names
    '--------------------------
    Set oRng = oWS.Range("a2")
    oRng.CopyFromRecordset oRS
    
    '--------------------------
    '   Kill Recordset Object
    '--------------------------
    On Error Resume Next
    If oRS.State <> 0 Then
        oRS.Close
        Set oRS = Nothing
    Else
        Set oRS = Nothing
    End If

    '--------------------------
    '   Kill Recordset Object
    '--------------------------
    If oCN.State <> 0 Then
        oCN.Close
        Set oCN = Nothing
    Else
        Set oCN = Nothing
    End If


    Exit Sub
EH_ImportFromAccess:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "Public Sub ImportFromAccess()"
    Exit Sub
End Sub

Hi J

>>
I do however keep getting an error saying it can't recognize the file.
>>

I put file checking in the code to test whether the files exists -
does the error message say - in part - "File does not exist ..."

This is the code that tests for the files existence - its part of the code I posted ..

    '------------------------------
    '   Does Access File Exist ?
    '------------------------------
    If Len(sDoesFileExist) < 2 Then
        sTmp = "The file named " & vbCrLf & vbCrLf
        sTmp = sTmp & sFullAccessFileName & vbCrLf & vbCrLf
        sTmp = sTmp & "does not exist ...................................... terminating"
        MsgBox sTmp, vbCritical, "Public Sub ImportFromAccess()"
        Exit Sub
    End If

If that is the code that is firing off - then without a doubt - the directory + Filename
does not exist.

Can you post back precisely the directory and file name shown in the error message?

regards
John

Hi J

Thank you very much for posting that.

(a) We are past the Does Files exist thingie.

(b) Either - it is burping on sProvider or sDataSource

Can you put an F9 on the line .OPEN

Then can your put sProvider and sDataSource in the debugger and confirm
that they are as expected.

As I posted - the code I posted works - but you have disproved this given your
outcome.

So - I want to propose TWO changes.

First - can you confirm that you can manually open up the ACCESS database.
Second - I want to modify the sDataSource Variable as follows:

'------------------------------
'------------------------------
'Current
sDataSource = "Data Source = " & sPath & sACCDBName

'Add
sDataSource = "Data Source = " & "'" & sPath & sACCDBName & "'"
sDataSource = sDataSource & ";"

I have tested the revision and it also works.

regards
John

Hi J

I found the ADO error using google and it is here:
http://support.microsoft.com/kb/209050

-2147467259 (0x80004005) Unspecified Error

This kind of error leaves us no place to go so I want to make a suggestion.

(a) Manually create a NEW BLANK ACCESS database. You do NOT have to add any tables.

(b) Modifiy the code I post to point to the new BLANK database.

(c) Using F8 - walk down the code and see if it still crashes on the .OPEN line.

regards
John

Hi J

Please see my previous post about creating a NEW BLANK database.

If that fails - I am not certain whatelse to do.

regards
John

Hi J

I bumped into these two thingies - BUT - I _ain't_ literate enough to read them.

But please note:

This is not an issue in Visual Studio .NET if you are using ADO.NET. But if you are using ADO, it is an issue. For .NET specific issues, see KnowledgeBase article 840667: You receive unexpected errors when using ADO and ADO Multidimensional in a .NET Framework application

http://www.fmsinc.com/blog/post/Micr...ce-Pack-1.aspx

http://support.microsoft.com/kb/2517589

Perhaps one of the forum moderators have bumped up against this and so you might
want to email one of them.

Very sorry I could not help you.

regards
John

Hi J

Please read the links on my last post. There maybe a service pack issue with OS7 that kills ***ADO***.

I am not certain if it applies to your situation. I am _not_ certain if I am reading the link correctly,
but I think so.

regards
John

Hi J

This is just as any FYI. Code below tested and works. Uses DAO in place of ADO.

If u decide to give it a shot - DO NOT - reference DAO 3.6 in the references thingie - instead -
reference

' * Tools -> References -> Microsoft Office 12.0 Access Database engine Object Library

You can leave the current ADO references "as is".

regards
John

Public Sub ImportFromAccess_DAO()

    ' * Save work book as Macro Workbook
    ' * Add General Module Alt-F11 - Insert Module
    ' * Tools -> References -> Microsoft ActiveX Data Objects 2.8
    ' * Tools -> References -> Microsoft ActiveX Data Recordset 2.8 Library
    ' * Tools -> References -> Microsoft ADO Ext 2.8 for DDL and Security
    
    '----------------------------
    '   NEW
    '----------------------------
    ' * Tools -> References -> Microsoft Office 12.0 Access Database engine Object Library
    
    '----------------------------
    '   DO **** NOT **** USE ----> DAO Ext 3.6
    '----------------------------

    '----------------------------
    '   DAO Objects
    '----------------------------
    Dim oDBEngine As DAO.DBEngine
    Dim oWorkSpace As DAO.Workspace
    Dim oDB As DAO.Database
    Dim oRS As DAO.Recordset
    Dim oQD As DAO.QueryDef
    Dim oCN As DAO.Connection
    
    '----------------------------
    '   Properties
    '----------------------------
    Dim sPath As String
    Dim sACCDBName As String
    Dim sWBName As String
    Dim sExtender As String
    Dim sDataSource As String
    Dim sCNString As String
    Dim sFullAccessFileName As String
    Dim sDoesFileExist As String
    Dim sTmp As String
    
    '------------------------------
    '   Counters
    '------------------------------
    Dim mlngRSRecCNT As Long
    Dim mlngRSFieldCNT As Long
    
    '------------------------------
    '   Misc
    '------------------------------
    Dim i As Integer
    Dim lng As Long
    
    '------------------------------
    '   SQL variables
    '------------------------------
    Dim sSQL As String
    
    '----------------------------
    '   Init
    '----------------------------
    sPath = ThisWorkbook.Path & "\"             'Change to yours
    sACCDBName = "DBTarget.accdb"               'Change to yours
    sFullAccessFileName = sPath & sACCDBName
    sDoesFileExist = Dir(sFullAccessFileName)
    
    '------------------------------
    '   Does Access File Exist ?
    '------------------------------
    If Len(sDoesFileExist) < 2 Then
        sTmp = "The file named " & vbCrLf & vbCrLf
        sTmp = sTmp & sFullAccessFileName & vbCrLf & vbCrLf
        sTmp = sTmp & "does not exist ...................................... terminating"
        MsgBox sTmp, vbCritical, "Public Sub ImportFromAccess()"
        Exit Sub
    End If
    
    '------------------------------
    '   SQL Statement -
    '------------------------------
    '   Change to your Field Names
    '   Change to your Dates
    '   Change to your Table Name
    '------------------------------
    sSQL = "SELECT "
    sSQL = sSQL & " [Lastname], "
    sSQL = sSQL & " [Firstname], "
    sSQL = sSQL & " [MyRef], "
    sSQL = sSQL & " [MyDate] "
    sSQL = sSQL & " FROM "
    sSQL = sSQL & " [TargetTable] "
    sSQL = sSQL & " WHERE "
    sSQL = sSQL & " [MyDate] BETWEEN #12/27/2011# AND #2/27/2012#  "
    sSQL = sSQL & " ORDER BY "
    sSQL = sSQL & " [MyDate] "
    
    '----------------------------
    '   Init
    '----------------------------
    Set oDBEngine = New DBEngine
    Set oWorkSpace = oDBEngine.Workspaces(0)
    Set oDB = oWorkSpace.OpenDatabase(sFullAccessFileName)
    Set oRS = oDB.OpenRecordset(sSQL)
    
    '----------------------------
    '   Ignore for now
    '----------------------------
    If 1 = 2 Then
        Set oQD = oDB.CreateQueryDef("", sSQL)
    End If

    '------------------------------
    '   Record Count and Field Count
    '------------------------------
    If Not oRS.BOF And Not oRS.EOF Then
        oRS.MoveLast
        oRS.MoveFirst
        mlngRSRecCNT = oRS.RecordCount
        mlngRSFieldCNT = oRS.Fields.Count
    Else
        '------------------------------
        '   No Records were returned
        '------------------------------
        sTmp = "The Recordset did not return any records " & vbCrLf & vbCrLf
        sTmp = sTmp & sSQL & vbCrLf & vbCrLf
        sTmp = sTmp & "Terminating ......"
        MsgBox sTmp, vbCritical, "Public Sub ImportFromAccess()"
        Exit Sub
    End If

    '--------------------------
    '   Write to a WS NAMED Target
    '--------------------------
    sWS = "Target"
    Set oWS = Sheets(sWS)
    With oWS
        .Activate
        .Cells.Delete
    End With
    
    '--------------------------
    '   Write FIELD Names
    '--------------------------
    For lng = 1 To mlngRSFieldCNT
        oWS.Rows(1).Columns(lng) = oRS.Fields(lng - 1).Name
    Next

    '--------------------------
    '   Write FIELD Names
    '--------------------------
    Set oRng = oWS.Range("a2")
    oRng.CopyFromRecordset oRS


End Sub