Issue with Code Creating Excel File

[BW]

I'm a novice at the vba side of things and need a "cleaner" excel output
than just transfereing a table to spreadsheet or outputing a report to
excel.

I have created the following function to create an excel sheet and populat
the following information. (I will be adding rows of data after I get this
fixed but needed a starting point).

The function runs and creates the excel sheet and puts all of the
informaiton into it. But if I try and run the code again to create a
second sheet it gives me the following error

Run-time error '1004'
Method 'Range' of object'_Global' failed

It starts the next instance of excel before it errors out.

I also have to admit that the code that puts the informaiton in the cells
was copied from a Macro I recorded in excel to see what syntax needed to be
used.


What am I doing wrong with this?

Thanks in advance...
BW

Function FreddieMacBilling()

Dim xlapplication As Excel.Application
Dim xlworkbook As Excel.Workbook
Set xlapplication = CreateObject("excel.application")
xlapplication.Visible = True
Set xlworkbook = xlapplication.Workbooks.Add

Range("A1").Select
ActiveCell.FormulaR1C1 = "Company Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "ABC CORP"
Range("C1").Select
ActiveCell.FormulaR1C1 = "5555555-555"
Range("D1").Select
ActiveCell.FormulaR1C1 = "bla bla bla Anytown , IN 55555"
Range("E1").Select
ActiveCell.FormulaR1C1 = "555-555-5555"
Range("B3").Select
ActiveCell.FormulaR1C1 = "Billing"
Range("C3").Select
ActiveCell.FormulaR1C1 = "12/1/2006"
Range("F3").Select
ActiveCell.FormulaR1C1 = "Spreedsheet 12012006"
Range("A5").Select
End Function

 

[DomThePom]

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!

 

[BW]

Thanks...works great..

Brent

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!