Exporting Access 97 tables/queries to Excel

[PeterIOM]

What I'm after as major time saving tool is to be able to export queries and tables from Access, into Excel in specific sheets and specific cells.

Can anyone help me with a bit of code that does so!? Thanks.

 

[mincefish]

This code will wang info into an Excel file:

Function fncStreamtoXL(strSQL As String, strFileName As String, Optional strHeader As String) As Boolean
On Error GoTo Err_Handle
Dim rstOutput As New ADODB.Recordset
Dim iRecCnt As Long
Dim iFldCnt As Long
Dim objOutFile, objOutStream, objOutSys
Const cForReading = 1, cForWriting = 2

The Function ConnectRecordset is simply a function that we use to connect to recordsets - its a pretty generic ADO function, and it simply means we don't have to write the open recordset code out over and over again! If you don't know how to connect to an ADO Recordset, let me know, and I'll post that code too.

'---------Connect Reordset
If Not ConnectRecordset(rstOutput, strSQL) Then
    MsgBox strSQL, , "In: mdlStreamText_fncStreamtoXL"
    GoTo Err_Exit
End If

Set objOutSys = CreateObject("Scripting.FileSystemObject")
Set objOutFile = objOutSys.CreateTextFile(strFileName, True)
Set objOutFile = objOutSys.GetFile(strFileName)
Set objOutStream = objOutFile.OpenAsTextStream(cForWriting)

'write header to file
If Not IsNull(strHeader) Then
    For iFldCnt = 0 To rstOutput.Fields.Count - 1
        strHeader = strHeader & rstOutput.Fields(iFldCnt).Name & vbTab
    Next
End If
objOutStream.Write (strHeader)
objOutStream.Writeline


'get recordcount
If rstOutput.BOF = True Then
    rstOutput.Close
    MsgBox "No Records Found To Output!"
    fncStreamtoXL = False
    Exit Function
End If

'This counts the number of records, to pass to the write method for objOutput
Do Until rstOutput.EOF
    iRecCnt = iRecCnt + 1
    rstOutput.MoveNext
Loop

rstOutput.MoveFirst

objOutStream.Write (rstOutput.GetString(adClipString, iRecCnt, vbTab, vbNewLine, ""))
objOutStream.Close

rstOutput.Close
If conADO.State = adStateOpen Then conADO.Close

fncStreamtoXL = True

Err_Exit:
    Exit Function

Err_Handle:
    MsgBox Err.Description, vbOKOnly, Err.Number & " In: fncGlobal_NBReport_Output"
    fncStreamtoXL = False
    GoTo Err_Exit

End Function

 

[PeterIOM]

Hi there,

Yeah I'm not sure how to conenct to an ADO recordset. The code you sent before, is that ready to send queries and tables from Access into Excel?

Thanks.

 

[mincefish]

Here are two functions that you could place in a module within the database. This is using ADO within Access97, and requires a reference to msado25.tlb - the ActiveX Data Objects 2.5 Reference.

Firstly, there's the setting up of the connections strings, which needs to set at the start of the procedure, and only needs to be done once - this uses public variables.

Public conADO As New ADODB.Connection
Public strCONnADO As String
Public strCONnODBC As String

Then there's the function to do the connecting - my connection strings are specific to two SQL Servers (one Prod, and one UAT - hence the blnLiveData part). You would have to tailor these to your specific circumstances - be it connecting to Access, or SQL Server...

Public Function fncSwitchToLiveData(blnLiveData As Boolean) As Boolean
On Error GoTo ERRHANDLE

    If blnLiveData Then
        strCONnADO = "Provider=SQL OLEDB.1;" & _
                                "User ID=sa;password=;" & _
                                "Initial Catalog=DMT;" & _
                                "Data Source=SUTSQL01"
                                                    
        strCONnODBC = "ODBC;DRIVER=SQL Server;" & _
                                "SERVER=SUTSQL01;" & _
                                "APP=Microsoft® Access;" & _
                                "DATABASE=DMT;" & _
                                "Trusted_Connection=Yes"
    Else
        strCONnADO = "Provider=SQL OLEDB.1;" & _
                                "User ID=sa;password=;" & _
                                "Initial Catalog=EhOH;" & _
                                "Data Source=CRODTM07"
                                                    
        strCONnODBC = "ODBC;DRIVER=SQL Server;" & _
                                "SERVER=CRODTM07;" & _
                                "APP=Microsoft® Access;" & _
                                "DATABASE=EhOH;" & _
                                "Trusted_Connection=Yes"
    End If
    
    fncSwitchToLiveData = True
    
ERREXIT:
    Exit Function
    
ERRHANDLE:
    MsgBox "In fncSwitchToLiveData @" & Err.Description & "@" & Err.Number, , "Utilities.mdlADO"
    fncSwitchToLiveData = False
    Resume ERREXIT

End Function

Once the connection is set, then that's done with. Next thing you want in your module is the ConnectRecordset Function. This makes some assumptions, but by the by, they're pretty good assumptions I've found....

Public Function ConnectRecordset(ByRef rstADO As ADODB.Recordset, ByRef strSQL As String, _
                                            Optional ByRef intCType As Integer = adOpenDynamic, Optional ByRef intCLocation As Integer = adUseServer, _
                                            Optional ByRef intCLock As Integer = adLockOptimistic) As Boolean
On Error GoTo ERRHANDLE
'Opens a recordset using the ADO connection and SQL SELECT statement it is passed

    If conADO.State = adStateClosed Then
        conADO.ConnectionString = strCONnADO
        conADO.Open
    End If
    
    If rstADO.State = adStateOpen Then
        rstADO.Close
    End If
    
    rstADO.CursorType = intCType
    rstADO.CursorLocation = intCLocation
    rstADO.LockType = intCLock
    rstADO.Open strSQL, conADO
    
    ConnectRecordset = True
    
ERREXIT:
    Exit Function
    
ERRHANDLE:
    strSQL = Err.Description
    ConnectRecordset = False
    Resume ERREXIT

End Function

Once you have the Public variables, and those two functions in a module in the database, the Excel code should work beautifully, although I'll bet my right arm it won't....nothing is ever that simple....!!

I've had a thought about this whole thing, compared to what you've asked. This will essentially dump the results of a recordset into Excel, pretty quickly too.

However, if you want to be able to put headers in Excel,and then skip a couple of lines, and then put a couple of rows - that kinda specific to cells in Excel, then this isn't really it - still the ADO might be interesting!

I have done some of creating an Excel object, and writing to specific cells from within Access. I can help you with that - although I'll only be able to give general help....

Hope some of this has been use to you LOL

 

[PeterIOM]

Hi there, I've had a bash at the coding and so far the below code works as a function.

What I'd like to be able to do, is to be able to enter the headings of the columns in access into the function thru a form. Is this possible working from code below?

Thanks.

Peter.

CODE STARTS HERE!
----------------------------------------------------

Option Compare Database
Option Explicit

Function StreamToXL(strTable As String, strLocation As String, strStartingCell As String, strStartingSheet As String)
' Optional strCol1 As String, Optional strCol2 As String)

'Add references to Microsoft Excel in the Tools References section for this to work.
'A reference to DAO should be present already.
Dim db As Database
Dim rstTable As Recordset

Dim xlApp As New Excel.Application
Dim xlWkb As Excel.Workbook
Dim A As Integer
Dim File As String

'Open recordset with data from "strTable" table - uses a SQL statement to open the correct data.
Set db = CurrentDb 'OK
Set rstTable = db.OpenRecordset(strTable)

' Sets the connection to Excel
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Open(strLocation)


'This is the Starting Position Sheet
xlWkb.Application.Sheets(strStartingSheet).Activate
'This is the Starting Position Cell
xlWkb.Application.Range(strStartingCell).Select
A = 1

' Print current data in recordset.
rstTable.MoveFirst
Do While Not rstTable.EOF
' The following lines transfer the data to Excel,
' Offset(Row,Column) selects the cell to put the data in.
' A increases by 1 each loop. Therefore the output moves down a row each time.

xlApp.Application.ActiveCell.Offset(A, 0).Value = rstTable![policy number]
xlApp.Application.ActiveCell.Offset(A, 1).Value = rstTable![policy status]
rstTable.MoveNext
'plus extra columns as appropriate

A = A + 1
Loop

rstTable.Close
xlWkb.Save
xlWkb.Close
Set xlApp = Nothing

End Function

 

[mincefish]

That's pretty cool! I see what the offset is doing, but personally I would specify cells - you are specifying a starting place place, which is a nice touch, but I would this code seems to be specific to one process, as you have hardcoded the field names in....I'd use a For....Next loop to go through every field in the SQL.

If you wanted to put a row header, then you could have a part of that function that enters a header before the main Do While Not....Loop which wangs in the header first...the way the below code works is assumes that you have a list box, with the field headers in it - the RowSource would be parsed through (and you need to make sure that your list box delimiter is a semi-colon (). I've written a function called Split, which kinda mimics the Split function in perl. What this does is takes a list, and then divides it up by a specified delimiter, and loads each seperate value into an array. So if you've got a list like this:

tom, dog, cat, 3, 55, England

and you do a 'split' on it, then it will give you an array with 6 elements. Its then pretty easy to reference each part. You'll see fncSplit below the function you supplied, which I've amended slightly. Where I've added or amended bits, I've put a line of hashes (#) to make it more obvious!

Function StreamToXL(strTable As String, strLocation As String, strStartingCell As String, strStartingSheet As String)
             '       Optional strCol1 As String, Optional strCol2 As String, Optional strHeader as string)

    'Add references to Microsoft Excel in the Tools References section for this to work.
    'A reference to DAO should be present already.
    Dim db As Database
    Dim rstTable As Recordset
    
    Dim xlApp As New Excel.Application
    Dim xlWkb As Excel.Workbook
    Dim A As Integer
    Dim File As String
    Dim iCtr As Integer ' for both for.....next loops
    
    Dim arrResult() ' to hold the split header
    
    'Open recordset with data from "strTable" table - uses a SQL statement to open the correct data.
    Set db = CurrentDb                      'OK
    Set rstTable = db.OpenRecordset(strTable)
    
    ' Sets the connection to Excel
    Set xlApp = New Excel.Application
    Set xlWkb = xlApp.Workbooks.Open(strLocation)

    
    'This is the Starting Position Sheet
    xlWkb.Application.Sheets(strStartingSheet).Activate
    'This is the Starting Position Cell
    xlWkb.Application.Range(strStartingCell).Select
    A = 1
  '###############################
  'Insert Header.
    
    If Not (strHeader = vbNullString) Then
        Call fncSplit(strHeader, ";", arrResult())
        For iCtr = 0 To UBound(arrResult) - 1
            xlApp.Application.ActiveCell.Offset(-1, iCtr).Value = arrResult(iCtr)
        Next
    End If
    
    ' Print current data in recordset.
    rstTable.MoveFirst
    Do While Not rstTable.EOF
        ' The following lines transfer the data to Excel,
        ' Offset(Row,Column) selects the cell to put the data in.
        ' A increases by 1 each loop. Therefore the output moves down a row each time.
  '###########################################
   'Amended here   
        For iCtr = 0 To rstTable.Fields.Count - 1 ' loop through every field in the recordset!
                            ' we do count -1 cos the count is 1 more than the last actual position, as recordsets start from 0
            xlApp.Application.ActiveCell.Offset(A, iCtr).Value = rstTable.Fields(iCtr).Value
            
        Next
        
        rstTable.MoveNext
'plus extra columns as appropriate

        A = A + 1
    Loop

    rstTable.Close
    xlWkb.Save
    xlWkb.Close
    Set xlApp = Nothing

End Function
'#######################################################

Function fncSplit(strString As String, strSplitBy As String, ByRef arrResult(), Optional iArrCtr As Integer)
Rem This function will take the parsed string, and split it using a parsed string (e.g.
Rem splitting a comma delimited file by the commas. It will write each element into arrResults
Rem and parse it back to the function that called it.
Rem You must Dim the array that is parsed to 'split' within the fuction that is calling it.
Rem The maximum size of the array is just over 32,000 elements.
Dim iChrCtr As Long
Dim strTemp As String
Dim strFinal As String
Dim strMsg As String

iArrCtr = 0

For iChrCtr = 1 To Len(strString)
    strTemp = Mid(strString, iChrCtr, 1) 'pull next character from string
    If strTemp = strSplitBy Or iChrCtr = Len(strString) Then ' if we are at the end of the string (this is to get the last word), or the char we are on matches the
                                                                                'strSplitBy string parsed, then run this code
        If iChrCtr = Len(strString) And strTemp <> strSplitBy Then   ' If we are on the last character, then add it to table final, otherwise it won't get added on. Could have added a
                                                    'comma to the end of the string, but that might have added problems
            strFinal = strFinal & strTemp
           
        Else
            ReDim Preserve arrResult(iArrCtr + 1) As Variant 'Redim the array, so it always one bigger than the last element we added. This was we have an array
                                                                                'that grows depending on the size of the data
        End If
               
        arrResult(iArrCtr) = strFinal    ' Add strFinal to the next free element of the array
        iArrCtr = iArrCtr + 1 ' increment the array counter
        strFinal = &quot;&quot; ' remove all from strFinal
        
    Else
    
        strFinal = strFinal & strTemp
        
    End If
    
Next

End Function

I hope I haven't chucked too much stuff at you here, and I hope I've a) got the right end of the stick, b) made it clear what I'm doing....

Good luck, and holler if you've got any questions!

Mincefish.