Hi Bill
Here's one I posted last week:
I am assuming that you are try to export a table or query to excel?
Here is a simple class that will do the job. Instructions on how to create
and use the class module are included below.
*********************************************
*********************************************
'Purpose of class is to export query / table into a simple Excel List
'Properties as follows:
' PROP DATA TYPE DESCRIPTION
' qry Text Name of existing table or query to be exported
to Excel
' title array(Text) (Optional) 1 to 3 component array for title of
report
' e.g Array("Sales Report", "30.06.2006",
"Year to Date"
'To run code:
'1. Go to the VB environment (Alt+F11 from the database window)
'2. From the menu select Tools / References and ensure that you have checked
references
' for Microsoft Excel 11.0 object library and Microsoft DA0 3.6 Object
library
'3. From the menu select Insert / ClassModule
'4. In the properties window (F4 if not visible) name the new class
clsXLlistSimple
'5. Paste this entire text into the class module (all text between double
******'s)
'6. From the menu select Insert / Module
'7. Paste the follwing sub into the module (all test between *****) and
remove far left "'"s
'8. Set properties appropriately in RunclsXLlistSimple
'9. Run the sub from a form or in code as required
'***********************************************************
'Sub RunclsXLlistSimple()
' Dim obj As New clsXLlistSimple
' On Error GoTo ProcError
' With obj
' .qry = "qryzzTest1"
' .Title = Array("Title Line 1", "Title Line 2", "Title Line 3")
' .RunXLList
' End With
'ProcExit:
' Set obj = Nothing
' Exit Sub
'ProcError:
' MsgBox Err.Source & " - " & Err.Description
' Resume ProcExit
'
'End Sub
'*****************************************************
'Note:The Class below uses the copyFromRecordset method of the range object
'This is more complex than using the simple docmd.TransferSpreadsheet
'However it offers the following advantages:
' a)TransferSpreadsheet is limited in the number of rows it can handle (I
think around 20,000)
' b)using copyFromRecordset you can present and format the dat in any way
you want
Private pvarTitle As Variant 'variant array of title lines
Private pstrQry As String 'query / table to export to excel
Public Property Get qry() As String
qry = pstrQry
End Property
Public Property Let qry(ByVal strQry As String)
pstrQry = strQry
End Property
Public Property Get Title() As Variant
Title = pvarTitle
End Property
Public Property Let Title(ByVal varTitle As Variant)
pvarTitle = varTitle
End Property
Public Function RunXLList()
'function exports qry / table to excel
'simple export - 3 line title
Dim tb As Excel.OLEObject
Dim xlApp As Excel.Application
Dim wbk As Excel.Workbook
Dim wst As Excel.Worksheet
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim icols As Integer
Dim rng As Excel.Range
Dim intTitleLines As Integer
Dim intI As Integer
Dim xlshtSource As Excel.Worksheet
Dim xlrng As Excel.Range
Dim qdf As QueryDef
Dim intRowStart As Integer
On Error GoTo ProcError
'get hold of existing or new excel application
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = New Excel.Application
End If
'create new workbook and define shett to work with
Set wbk = xlApp.Workbooks.Add
Set wst = wbk.Sheets(1)
wst.Name = "List"
xlApp.Visible = True
'set up the query to be exported
Set db = CurrentDb
Set rst = db.OpenRecordset(pstrQry, dbOpenSnapshot)
'determine number of rows in title and starting point
If IsEmpty(pvarTitle) = True Then
intRowStart = 1
intTitleLines = 0
ElseIf IsArray(pvarTitle) = False Then
intRowStart = 3
intTitleLines = 1
Else
intTitleLines = UBound(pvarTitle) + 1
intRowStart = intTitleLines + 2
End If
'fill and format title ()
If intTitleLines = 1 Then
wst.Cells(1, 1).Formula = pvarTitle
ElseIf intTitleLines > 1 Then
For intI = 0 To intTitleLines - 1
wst.Cells(intI + 1, 1).Formula = pvarTitle(intI)
Next intI
End If
If intTitleLines > 0 Then
With wst.Range("A1:A" & intTitleLines).Font
.Name = "Arial"
.Size = 12
.ColorIndex = 11
.Bold = True
End With
End If
'insert and format column headers
For icols = 0 To rst.Fields.Count - 1
wst.Cells(intRowStart, icols + 1).Value = rst.Fields(icols).Name
Next
wst.Range(wst.Cells(1, 1), _
wst.Cells(1, rst.Fields.Count)).Font.Bold = True
Set rng = wst.Cells(intRowStart + 1, 1)
'freeze panes
rng.EntireRow.Select
xlApp.ActiveWindow.FreezePanes = True
rng.Select
'copy in data
rng.CopyFromRecordset rst
'define and format data range
With rng.CurrentRegion
.WrapText = False
.CurrentRegion.AutoFormat Format:=xlRangeAutoFormatList3
.Font.Size = 8
.Columns.AutoFit
End With
wst.Activate
wst.Cells(1, 1).Select
ProcExit:
Set db = Nothing
Set rst = Nothing
Set xlApp = Nothing
Set wbk = Nothing
Set wst = Nothing
Set rng = Nothing
Exit Function
ProcError:
MsgBox Error(Err)
Resume ProcExit
End Function
*************************************
*************************************
Enjoy!
