Writting ACCESS table to Excel

[mls via AccessMonster.com]

I am trying to write to Excel and have this code.. which fails at line Dim
Rst1 As New ADODB.Recordset, saying "User definded type not defined" . Also
after witrring I want to rename my template
Any thoughts?

Sub xl()
Dim DXrptPath As String
DXrptPath = "r:\temp\Resultsreportingworksheet.xls"

'***Opening Report Template
Dim myDB As Database
Set myDB = CurrentDb
Set ExcelWindow = CreateObject("excel.application")
ExcelWindow.Visible = True
ExcelWindow.Workbooks.Open (DXrptPath)
Dim DXrpt As Workbook
Set DXrpt = ActiveWorkbook


DXrpt.Application.WindowState = xlMinimized

Dim Rst1 As New ADODB.Recordset
'Set Rst1 = myDB.OpenRecordset("ABI_XL")

With Rst1
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.ActiveConnection = CurrentProject.Connection
.Open "[ABI_XL]"
End With
DXrpt.Worksheets(1).Range("b20:k20").CopyFromRecordset Rst1
End Sub

 

[Stefan Hoffmann]

hi,

I am trying to write to Excel and have this code.. which fails at line Dim
Rst1 As New ADODB.Recordset, saying "User definded type not defined" .

This indicates that you have not a reference to the Microsoft ADO library.

Take a look at the ExportToExcel function:

http://bytes.com/topic/access/answers/207463-sql-syntax-question


mfG
--> stefan <--

 

[GeoffG]

I think it's better to use DAO.
Here's how
(copy and paste the following code into a new module):


Option Compare Database
Option Explicit

' This module requires the following references:
'
' 1. Microsoft DAO Object Library
' 2. Microsoft Excel Object Library
'
' (To create the references, in the VBA editor,
' open the Tools Menu, select References, and
' then select the two above object libraries.)

Sub DXReport()

' DX REPORT:
'
' This subprocedure declares constants
' specific to the DX Report.
' Other reports (if any) can use
' different values in these constants
' and still call the next subprocedure
' CopyFromRecordsetToXL().

' Declare constants:
Const strcRecordSource As String = "ABI_XL"
Const strcWorkBookPath As String = _
"r:\temp\ResultsReportingWorksheet.xls"
Const strcStartCopyingAt As String = "B20"
Const strcWorkbookSavePath As String = _
"r:\temp\"
Const strcWorkbookSaveName As String = _
"ResultsReportingWorksheet.xls"

Dim strNow As String
Dim strSaveName As String

' Create a new SaveAs name with a
' date/time prefix.
' Note: The date prefix is in reverse
' (YYYYMMDD) order so files will be listed
' in date order in Windows Explorer.
strNow = Format(Now(), "YYYYMMDD HHNN")
strSaveName = strcWorkbookSavePath _
& strNow & " " & strcWorkbookSaveName

' Call generic routine:
Call CopyFromRecordsetToXL(strcRecordSource, _
strcWorkBookPath, strcStartCopyingAt, _
strSaveName)

End Sub

Sub CopyFromRecordsetToXL(strRecordSource As String, _
strWorkBookPath As String, _
strStartCopyingAt As String, _
strSaveAsName As String)

' Access objects:
Dim objDB As DAO.Database
Dim objRST As DAO.Recordset

' Excel objects:
Dim objXL As Excel.Application
Dim objWBK As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRNG As Excel.Range

On Error GoTo Error_CopyFromRecordsetToXL

' Start Excel:
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
On Error GoTo Error_CopyFromRecordsetToXL
Set objXL = CreateObject("Excel.Application")
End If
On Error GoTo Error_CopyFromRecordsetToXL
With objXL
.Visible = True
.WindowState = xlMinimized
End With
Set objWBK = objXL.Workbooks.Open(strWorkBookPath)
Set objWS = objWBK.Worksheets(1)
Set objRNG = objWS.Range(strStartCopyingAt)

' DAO objects:
Set objDB = CurrentDb()
Set objRST = objDB.OpenRecordset(strRecordSource)

' Copy data:
objRNG.CopyFromRecordset objRST

' Save Excel Workbook using a different name:
objWBK.SaveAs strSaveAsName

Exit_CopyFromRecordsetToXL:

' Destroy DAO objects:
If Not objRST Is Nothing Then
objRST.Close
Set objRST = Nothing
End If
Set objDB = Nothing

' Destroy Excel objects:
Set objRNG = Nothing
Set objWS = Nothing
If Not objWBK Is Nothing Then
' Don't save changes here!
objWBK.Close SaveChanges:=False
Set objWBK = Nothing
End If
If Not objXL Is Nothing Then
objXL.Quit
Set objXL = Nothing
End If

Exit Sub

Error_CopyFromRecordsetToXL:

MsgBox "Error Number: " & Err.Number _
& vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"

Resume Exit_CopyFromRecordsetToXL

End Sub


Geoff

I am trying to write to Excel and have this code.. which
fails at line Dim
Rst1 As New ADODB.Recordset, saying "User definded type
not defined" . Also
after witrring I want to rename my template
Any thoughts?

Sub xl()
Dim DXrptPath As String
DXrptPath = "r:\temp\Resultsreportingworksheet.xls"

'***Opening Report Template
Dim myDB As Database
Set myDB = CurrentDb
Set ExcelWindow = CreateObject("excel.application")
ExcelWindow.Visible = True
ExcelWindow.Workbooks.Open (DXrptPath)
Dim DXrpt As Workbook
Set DXrpt = ActiveWorkbook


DXrpt.Application.WindowState = xlMinimized

Dim Rst1 As New ADODB.Recordset
'Set Rst1 = myDB.OpenRecordset("ABI_XL")

With Rst1
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.ActiveConnection = CurrentProject.Connection
.Open "[ABI_XL]"
End With
DXrpt.Worksheets(1).Range("b20:k20").CopyFromRecordset
Rst1
End Sub

 

[Stuart McCall]

I think it's better to use DAO.
Here's how
(copy and paste the following code into a new module):


Option Compare Database
Option Explicit

' This module requires the following references:
'
' 1. Microsoft DAO Object Library
' 2. Microsoft Excel Object Library
'
' (To create the references, in the VBA editor,
' open the Tools Menu, select References, and
' then select the two above object libraries.)

Sub DXReport()

' DX REPORT:
'
' This subprocedure declares constants
' specific to the DX Report.
' Other reports (if any) can use
' different values in these constants
' and still call the next subprocedure
' CopyFromRecordsetToXL().

' Declare constants:
Const strcRecordSource As String = "ABI_XL"
Const strcWorkBookPath As String = _
"r:\temp\ResultsReportingWorksheet.xls"
Const strcStartCopyingAt As String = "B20"
Const strcWorkbookSavePath As String = _
"r:\temp\"
Const strcWorkbookSaveName As String = _
"ResultsReportingWorksheet.xls"

Dim strNow As String
Dim strSaveName As String

' Create a new SaveAs name with a
' date/time prefix.
' Note: The date prefix is in reverse
' (YYYYMMDD) order so files will be listed
' in date order in Windows Explorer.
strNow = Format(Now(), "YYYYMMDD HHNN")
strSaveName = strcWorkbookSavePath _
& strNow & " " & strcWorkbookSaveName

' Call generic routine:
Call CopyFromRecordsetToXL(strcRecordSource, _
strcWorkBookPath, strcStartCopyingAt, _
strSaveName)

End Sub

Sub CopyFromRecordsetToXL(strRecordSource As String, _
strWorkBookPath As String, _
strStartCopyingAt As String, _
strSaveAsName As String)

' Access objects:
Dim objDB As DAO.Database
Dim objRST As DAO.Recordset

' Excel objects:
Dim objXL As Excel.Application
Dim objWBK As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRNG As Excel.Range

On Error GoTo Error_CopyFromRecordsetToXL

' Start Excel:
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
On Error GoTo Error_CopyFromRecordsetToXL
Set objXL = CreateObject("Excel.Application")
End If
On Error GoTo Error_CopyFromRecordsetToXL
With objXL
.Visible = True
.WindowState = xlMinimized
End With
Set objWBK = objXL.Workbooks.Open(strWorkBookPath)
Set objWS = objWBK.Worksheets(1)
Set objRNG = objWS.Range(strStartCopyingAt)

' DAO objects:
Set objDB = CurrentDb()
Set objRST = objDB.OpenRecordset(strRecordSource)

' Copy data:
objRNG.CopyFromRecordset objRST

' Save Excel Workbook using a different name:
objWBK.SaveAs strSaveAsName

Exit_CopyFromRecordsetToXL:

' Destroy DAO objects:
If Not objRST Is Nothing Then
objRST.Close
Set objRST = Nothing
End If
Set objDB = Nothing

' Destroy Excel objects:
Set objRNG = Nothing
Set objWS = Nothing
If Not objWBK Is Nothing Then
' Don't save changes here!
objWBK.Close SaveChanges:=False
Set objWBK = Nothing
End If
If Not objXL Is Nothing Then
objXL.Quit
Set objXL = Nothing
End If

Exit Sub

Error_CopyFromRecordsetToXL:

MsgBox "Error Number: " & Err.Number _
& vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"

Resume Exit_CopyFromRecordsetToXL

End Sub


Geoff

I am trying to write to Excel and have this code.. which fails at line
Dim
Rst1 As New ADODB.Recordset, saying "User definded type not defined" .
Also
after witrring I want to rename my template
Any thoughts?

Sub xl()
Dim DXrptPath As String
DXrptPath = "r:\temp\Resultsreportingworksheet.xls"

'***Opening Report Template
Dim myDB As Database
Set myDB = CurrentDb
Set ExcelWindow = CreateObject("excel.application")
ExcelWindow.Visible = True
ExcelWindow.Workbooks.Open (DXrptPath)
Dim DXrpt As Workbook
Set DXrpt = ActiveWorkbook


DXrpt.Application.WindowState = xlMinimized

Dim Rst1 As New ADODB.Recordset
'Set Rst1 = myDB.OpenRecordset("ABI_XL")

With Rst1
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.ActiveConnection = CurrentProject.Connection
.Open "[ABI_XL]"
End With
DXrpt.Worksheets(1).Range("b20:k20").CopyFromRecordset Rst1
End Sub

Geoff

A strange piece of hybrid code - using both early and late binding, but very
nice nonetheless.

Duly filched for future use ;-)

 

[GeoffG]

Hi Stuart,

I hope you're well.
(I recall you make regular hospital trips?)

Your comment lost me.
Please explain what you think is late bound.
No objects are declared "As Object"; all are declared with
their class name; for example:

DAO in:
I'm baffled and I'd like to have your take on it.

All the best
Geoff

I think it's better to use DAO.
Here's how
(copy and paste the following code into a new module):


Option Compare Database
Option Explicit

' This module requires the following references:
'
' 1. Microsoft DAO Object Library
' 2. Microsoft Excel Object Library
'
' (To create the references, in the VBA editor,
' open the Tools Menu, select References, and
' then select the two above object libraries.)

Sub DXReport()

' DX REPORT:
'
' This subprocedure declares constants
' specific to the DX Report.
' Other reports (if any) can use
' different values in these constants
' and still call the next subprocedure
' CopyFromRecordsetToXL().

' Declare constants:
Const strcRecordSource As String = "ABI_XL"
Const strcWorkBookPath As String = _
"r:\temp\ResultsReportingWorksheet.xls"
Const strcStartCopyingAt As String = "B20"
Const strcWorkbookSavePath As String = _
"r:\temp\"
Const strcWorkbookSaveName As String = _
"ResultsReportingWorksheet.xls"

Dim strNow As String
Dim strSaveName As String

' Create a new SaveAs name with a
' date/time prefix.
' Note: The date prefix is in reverse
' (YYYYMMDD) order so files will be listed
' in date order in Windows Explorer.
strNow = Format(Now(), "YYYYMMDD HHNN")
strSaveName = strcWorkbookSavePath _
& strNow & " " & strcWorkbookSaveName

' Call generic routine:
Call CopyFromRecordsetToXL(strcRecordSource, _
strcWorkBookPath, strcStartCopyingAt, _
strSaveName)

End Sub

Sub CopyFromRecordsetToXL(strRecordSource As String, _
strWorkBookPath As String, _
strStartCopyingAt As String, _
strSaveAsName As String)

' Access objects:
Dim objDB As DAO.Database
Dim objRST As DAO.Recordset

' Excel objects:
Dim objXL As Excel.Application
Dim objWBK As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRNG As Excel.Range

On Error GoTo Error_CopyFromRecordsetToXL

' Start Excel:
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
On Error GoTo Error_CopyFromRecordsetToXL
Set objXL = CreateObject("Excel.Application")
End If
On Error GoTo Error_CopyFromRecordsetToXL
With objXL
.Visible = True
.WindowState = xlMinimized
End With
Set objWBK = objXL.Workbooks.Open(strWorkBookPath)
Set objWS = objWBK.Worksheets(1)
Set objRNG = objWS.Range(strStartCopyingAt)

' DAO objects:
Set objDB = CurrentDb()
Set objRST = objDB.OpenRecordset(strRecordSource)

' Copy data:
objRNG.CopyFromRecordset objRST

' Save Excel Workbook using a different name:
objWBK.SaveAs strSaveAsName

Exit_CopyFromRecordsetToXL:

' Destroy DAO objects:
If Not objRST Is Nothing Then
objRST.Close
Set objRST = Nothing
End If
Set objDB = Nothing

' Destroy Excel objects:
Set objRNG = Nothing
Set objWS = Nothing
If Not objWBK Is Nothing Then
' Don't save changes here!
objWBK.Close SaveChanges:=False
Set objWBK = Nothing
End If
If Not objXL Is Nothing Then
objXL.Quit
Set objXL = Nothing
End If

Exit Sub

Error_CopyFromRecordsetToXL:

MsgBox "Error Number: " & Err.Number _
& vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"

Resume Exit_CopyFromRecordsetToXL

End Sub


Geoff

I am trying to write to Excel and have this code.. which
fails at line Dim
Rst1 As New ADODB.Recordset, saying "User definded type
not defined" . Also
after witrring I want to rename my template
Any thoughts?

Sub xl()
Dim DXrptPath As String
DXrptPath = "r:\temp\Resultsreportingworksheet.xls"

'***Opening Report Template
Dim myDB As Database
Set myDB = CurrentDb
Set ExcelWindow = CreateObject("excel.application")
ExcelWindow.Visible = True
ExcelWindow.Workbooks.Open (DXrptPath)
Dim DXrpt As Workbook
Set DXrpt = ActiveWorkbook


DXrpt.Application.WindowState = xlMinimized

Dim Rst1 As New ADODB.Recordset
'Set Rst1 = myDB.OpenRecordset("ABI_XL")

With Rst1
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.ActiveConnection = CurrentProject.Connection
.Open "[ABI_XL]"
End With
DXrpt.Worksheets(1).Range("b20:k20").CopyFromRecordset
Rst1
End Sub

Geoff

A strange piece of hybrid code - using both early and late
binding, but very nice nonetheless.

Duly filched for future use ;-)

 

[Stuart McCall]

Comments inline:

Hi Stuart,

I hope you're well.
(I recall you make regular hospital trips?)

Yes, well remembered. Still the same scenario - ho hum.
I'm also typing one-handed these days, which is why my posts may seem a bit
terse. The truth is my arm is soon exhausted.

Your comment lost me.
Please explain what you think is late bound.

Well the line:

Set objXL = CreateObject("Excel.Application")

is a late-bound assignment, even though objXL is declared as
Excel.Application.
An early-bound assignment would be:

Set objXL = New Excel.Application

No objects are declared "As Object"; all are declared with
their class name; for example:

DAO in:

I'm baffled and I'd like to have your take on it.

Please don't take my comment as criticism. I can see why you do it this way
and that's one of the reasons I like the code.

All the best
Geoff

I think it's better to use DAO.
Here's how
(copy and paste the following code into a new module):


Option Compare Database
Option Explicit

' This module requires the following references:
'
' 1. Microsoft DAO Object Library
' 2. Microsoft Excel Object Library
'
' (To create the references, in the VBA editor,
' open the Tools Menu, select References, and
' then select the two above object libraries.)

Sub DXReport()

' DX REPORT:
'
' This subprocedure declares constants
' specific to the DX Report.
' Other reports (if any) can use
' different values in these constants
' and still call the next subprocedure
' CopyFromRecordsetToXL().

' Declare constants:
Const strcRecordSource As String = "ABI_XL"
Const strcWorkBookPath As String = _
"r:\temp\ResultsReportingWorksheet.xls"
Const strcStartCopyingAt As String = "B20"
Const strcWorkbookSavePath As String = _
"r:\temp\"
Const strcWorkbookSaveName As String = _
"ResultsReportingWorksheet.xls"

Dim strNow As String
Dim strSaveName As String

' Create a new SaveAs name with a
' date/time prefix.
' Note: The date prefix is in reverse
' (YYYYMMDD) order so files will be listed
' in date order in Windows Explorer.
strNow = Format(Now(), "YYYYMMDD HHNN")
strSaveName = strcWorkbookSavePath _
& strNow & " " & strcWorkbookSaveName

' Call generic routine:
Call CopyFromRecordsetToXL(strcRecordSource, _
strcWorkBookPath, strcStartCopyingAt, _
strSaveName)

End Sub

Sub CopyFromRecordsetToXL(strRecordSource As String, _
strWorkBookPath As String, _
strStartCopyingAt As String, _
strSaveAsName As String)

' Access objects:
Dim objDB As DAO.Database
Dim objRST As DAO.Recordset

' Excel objects:
Dim objXL As Excel.Application
Dim objWBK As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRNG As Excel.Range

On Error GoTo Error_CopyFromRecordsetToXL

' Start Excel:
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
On Error GoTo Error_CopyFromRecordsetToXL
Set objXL = CreateObject("Excel.Application")
End If
On Error GoTo Error_CopyFromRecordsetToXL
With objXL
.Visible = True
.WindowState = xlMinimized
End With
Set objWBK = objXL.Workbooks.Open(strWorkBookPath)
Set objWS = objWBK.Worksheets(1)
Set objRNG = objWS.Range(strStartCopyingAt)

' DAO objects:
Set objDB = CurrentDb()
Set objRST = objDB.OpenRecordset(strRecordSource)

' Copy data:
objRNG.CopyFromRecordset objRST

' Save Excel Workbook using a different name:
objWBK.SaveAs strSaveAsName

Exit_CopyFromRecordsetToXL:

' Destroy DAO objects:
If Not objRST Is Nothing Then
objRST.Close
Set objRST = Nothing
End If
Set objDB = Nothing

' Destroy Excel objects:
Set objRNG = Nothing
Set objWS = Nothing
If Not objWBK Is Nothing Then
' Don't save changes here!
objWBK.Close SaveChanges:=False
Set objWBK = Nothing
End If
If Not objXL Is Nothing Then
objXL.Quit
Set objXL = Nothing
End If

Exit Sub

Error_CopyFromRecordsetToXL:

MsgBox "Error Number: " & Err.Number _
& vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"

Resume Exit_CopyFromRecordsetToXL

End Sub


Geoff







I am trying to write to Excel and have this code.. which
fails at line Dim
Rst1 As New ADODB.Recordset, saying "User definded type
not defined" . Also
after witrring I want to rename my template
Any thoughts?

Sub xl()
Dim DXrptPath As String
DXrptPath = "r:\temp\Resultsreportingworksheet.xls"

'***Opening Report Template
Dim myDB As Database
Set myDB = CurrentDb
Set ExcelWindow = CreateObject("excel.application")
ExcelWindow.Visible = True
ExcelWindow.Workbooks.Open (DXrptPath)
Dim DXrpt As Workbook
Set DXrpt = ActiveWorkbook


DXrpt.Application.WindowState = xlMinimized

Dim Rst1 As New ADODB.Recordset
'Set Rst1 = myDB.OpenRecordset("ABI_XL")

With Rst1
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.ActiveConnection = CurrentProject.Connection
.Open "[ABI_XL]"
End With
DXrpt.Worksheets(1).Range("b20:k20").CopyFromRecordset
Rst1
End Sub

Geoff

A strange piece of hybrid code - using both early and late
binding, but very nice nonetheless.

Duly filched for future use ;-)

 

[mls via AccessMonster.com]

Hi GeoffG,

I have checked both the references DAO 3.6 and excel 11.0 libraries but still
it shows error message
Runtime ERROR 429 "ActiveXComponent can't create object. at line..
Set objXL = GetObject(, "Excel.Application")

When I commented the above line it works fine for one time and when I try to
run again it fails with Run-time Error ‘91’ "Object variable or With block
variable not set". at below block.

With objXL
.Visible = True
.WindowState = xlMinimized
End With


Also can you see if this is correct way of coding..

1) I have to create new folder with date inputted from the FORM control in
this format : 99\-99\-0000;0;_ and save the file with file name as Me.
csv_file, for which I have the following code..

Function make_dir()
Dim sDir As String
Dim sFile As String
sDirpath = "r:\temp\"
sDir = Me.dt
sFile = Me.csv_file

If FolderExist(sFile) = False Then
MkDir sFile
MsgBox "Directory " & sFile & " has been created"
'On Error Resume Next
'MkDir Me.dt
End If
End Function

2) Also I have to save this csv_file as filename: at B2 in my Excel template.

3) And I need to copy my field names at “B19†so I have the following code..

Dim fldCount As Integer
Dim iCol As Integer

' Copy field names to the worksheet
fldCount = objRST.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(19, iCol + 1).Value = rst.Fields(iCol - 1).Name
Next

Thanks a lot for helping me figure out things. I have done this automation in
another language and trying to convert all that to ACCESS. I am a newbie to
VBA and searching in web how to re-write each and every piece in ACCESS

Comments inline:

Hi Stuart,

I hope you're well.
(I recall you make regular hospital trips?)

Yes, well remembered. Still the same scenario - ho hum.
I'm also typing one-handed these days, which is why my posts may seem a bit
terse. The truth is my arm is soon exhausted.

Your comment lost me.
Please explain what you think is late bound.

Well the line:

Set objXL = CreateObject("Excel.Application")

is a late-bound assignment, even though objXL is declared as
Excel.Application.
An early-bound assignment would be:

Set objXL = New Excel.Application

No objects are declared "As Object"; all are declared with
their class name; for example:

[quoted text clipped - 5 lines]

I'm baffled and I'd like to have your take on it.

Please don't take my comment as criticism. I can see why you do it this way
and that's one of the reasons I like the code.

All the best
Geoff

[quoted text clipped - 177 lines]

 

[Stefan Hoffmann]

hi,

I have checked both the references DAO 3.6 and excel 11.0 libraries but still
it shows error message
Runtime ERROR 429 "ActiveXComponent can't create object. at line..
Set objXL = GetObject(, "Excel.Application")

GetObject tries to capture a running instance of Excel.Application. If
there is none it returns nothing.


mfG
--> stefan <--

 

[GeoffG]

Hi MLS,

I think the easiest way for me to respond is to make the
following recommendations:

1. Create a new blank form in your database.
2. Copy all of the new code below into the module behind
the new form.
3. Create all of the controls that I have used in the code,
i.e:

TextBoxes named:
txtFolderDate
txtFileName
Command Buttons named:
cmdRunDXReport
cmdTestMessage

You will need to create the above controls and give them the
above names. To do this, after creating each control, open
its property sheet, click in its Name property, and enter
the names above.

In the property sheets for the TextBoxes, click in the
Caption property and give them the captions "Run DX Report"
and "Run Test Messages".

In the property sheets for the Labels associated with the
TextBoxes, click in the Caption property and give them the
captions "Folder Date" and "FileName".

You should then be all set. The code listing below contains
code for the Click events for each of the Command Buttons.
As a consequence, the words [Event Procedure] should appear
automatically in each "On Click" property (in the property
sheet) of each of the buttons.

You should be able to run the form you have just created,
click the "Run DX Report" button and the code should run
without error. This assumes that I have understood your
requirements correctly and I'm not sure that I have.
However, the code should give you all the clues you need to
get you going.

Do ask again if you're stuck. I've been happy to blast
through this for you over the weekend, but my time during
the week is more limited, which means I may only have time
for quick responses.

Here's the code:
(Notice you have to make a new reference to "Microsoft
Scripting Runtime", which gives you easier ways of making
folders, testing for the existence of files, etc.)

START COPYING ON NEXT LINE

Option Compare Database
Option Explicit

' This is the code module behind a Form.
' (It's not evident from the newsgroup
' whether the form is bound or unbound
' but it should work anyway.)
'
'
' This module requires the following references:
'
' 1. Microsoft DAO Object Library
' 2. Microsoft Excel Object Library
' 3. Microsoft Scripting Runtime
'
' (To create the references, in the VBA editor,
' open the Tools Menu, select References, and
' then select the above object libraries.)


Private Sub cmdRunDXReport_Click()

' This is the Click event procedure for
' command button named cmdRunDXReport.

' Declare constants for the DX Report:
' Name of table or query:
Const strcRecordSource As String = "ABI_XL"
Const strcWorkBookTemplatePath As String = _
"r:\temp\ResultsReportingWorksheet.xls"
Const strcStartCopyingAtCell As String = "B19"
Const strcSaveNameAtCell As String = "B2"
Const strcSavePath As String = "r:\temp\"


' Use the F8 key to step through the code
' after the code stops at the next line (or
' use the "Step Into" toolbar button).
' After the code runs correctly, remove
' the following Stop command.
Stop


' Pass constants to the DXReport subprocedure:
Call DXReport(strcRecordSource, _
strcWorkBookTemplatePath, _
strcStartCopyingAtCell, _
strcSaveNameAtCell, _
strcSavePath)

End Sub


Private Sub DXReport(strRecordSource As String, _
strWorkBookTemplatePath As String, _
strStartCopyingAtCell As String, _
strSaveNameAtCell As String, _
strSavePath As String)

' DX REPORT PROCEDURE:

' Access objects:
Dim objDB As DAO.Database
Dim objRST As DAO.Recordset

' Excel objects:
Dim objXL As Excel.Application
Dim objWBK As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRNG1 As Excel.Range
Dim objRNG2 As Excel.Range
Dim objRNG3 As Excel.Range

' Scripting Objects:
Dim objFSO As Scripting.FileSystemObject

' Other variables:
Dim strSaveFolderName As String
Dim strSaveName As String
Dim strSavePathName As String
Dim fWeStartedExcel As Boolean
Dim intFieldCount As Integer
Dim iField As Integer


' IMPORTANT NOTE:
' Rem out the following code line
' (which sets up error handling)
' if you get errors when running
' this code. This will let you see
' which line is the problem. Then
' try to figure out why it's a
' problem. If you simply rem out the
' problem line, you will find that
' subsequent code lines will start
' causing problems. So adjust the
' code carefully when you understand
' what change is needed.
' Set up generic error handler:
On Error GoTo Error_DXReport

' Instantiate the FileSystemObject:
Set objFSO = New Scripting.FileSystemObject

' Instantiate DAO objects:
Set objDB = CurrentDb()
Set objRST = objDB.OpenRecordset(strRecordSource)
If objRST.RecordCount = 0 Then
Call Msg1
GoTo Exit_DXReport
End If


' VALIDATE DATA

' See if Excel template exists:
If Not objFSO.FileExists(strWorkBookTemplatePath) _
Then
Call Msg2
GoTo Exit_DXReport
End If

' See if the Save path exists:
If Not objFSO.FolderExists(strSavePath) Then
Call Msg3(strSavePath)
GoTo Exit_DXReport
End If

' See if user has entered a valid
' date in the TextBox "txtFolderDate".
' This date will be used to create a
' folder, in which the WorkBook will
' be saved.
If Not IsDate(Me.txtFolderDate) Then
Call Msg4
Me.txtFolderDate.SetFocus
GoTo Exit_DXReport
Else
' Format Save folder name.
' The TextBox "txtFolderDate" may or may
' not be in the correct format.
' The format "YYYY-MM-DD" seems preferable
' for listing files in Windows Explorer.
strSaveFolderName = _
Format(Me.txtFolderDate, "DD-MM-YYYY")
End If

' See if the user has entered a valid
' filename in the TextBox "txtFileName":
If IsNull(Me.txtFileName) Then
Call Msg5
Me.txtFileName.SetFocus
GoTo Exit_DXReport
Else

' Remove invalid characters (if any):
strSaveName = Me.txtFileName
strSaveName = Replace(strSaveName, "\", "")
strSaveName = Replace(strSaveName, "/", "")
strSaveName = Replace(strSaveName, ":", "")
strSaveName = Replace(strSaveName, "*", "")
strSaveName = Replace(strSaveName, "?", "")
strSaveName = Replace(strSaveName, """", "")
strSaveName = Replace(strSaveName, "<", "")
strSaveName = Replace(strSaveName, ">", "")
strSaveName = Replace(strSaveName, "|", "")

' Check for a zero-length filename;
If Len(strSaveName) = 0 Then
Call Msg5
GoTo Exit_DXReport
End If

' Ensure filename ends in ".xls":
If Right(strSaveName, 4) <> ".xls" Then
strSaveName = strSaveName & ".xls"
End If

End If

' Concatenate Date Folder to Save path:
strSavePath = objFSO.BuildPath( _
strSavePath, strSaveFolderName)

' Create Date Folder (if necessary):
If Not objFSO.FolderExists(strSavePath) Then
objFSO.CreateFolder (strSavePath)
End If

' Store full path (including filename):
strSavePathName = strSavePath & "\" & strSaveName

' Delete any existing file with same name:
If objFSO.FileExists(strSavePathName) Then
objFSO.DeleteFile (strSavePathName)
End If


' COPY RECORDSET TO EXCEL

' Start Excel.
' Use inline error handling to trap error
' caused by GetObject() if Excel is not
' already running and use CreateObject()
' instead.
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
On Error GoTo Error_DXReport
Set objXL = CreateObject("Excel.Application")
' Set flag to remember we started Excel:
fWeStartedExcel = True
End If
On Error GoTo Error_DXReport
With objXL
.Visible = True
.WindowState = xlMinimized
End With

' Open the WorkBook:
Set objWBK = objXL.Workbooks.Open( _
strWorkBookTemplatePath)
Set objWS = objWBK.Worksheets(1)

' Point to where copying is to begin:
Set objRNG1 = objWS.Range(strStartCopyingAtCell)

' Copy recordset field names to the worksheet:
intFieldCount = objRST.Fields.Count
For iField = 0 To intFieldCount - 1
Set objRNG2 = objRNG1.Offset(0, iField)
With objRNG2
.Value = objRST.Fields(iField).Name
.Font.Bold = True
End With
Next

' Point again to where copying is to begin,
' move down one row, and copy recordset data:
Set objRNG1 = objWS.Range(strStartCopyingAtCell)
Set objRNG1 = objRNG1.Offset(1, 0)
objRNG1.CopyFromRecordset objRST

' AutoFit columns to new data:
Set objRNG3 = objWS.Range(objRNG1.Address, _
objRNG2.Address)
objRNG3.Columns.AutoFit

' Save Excel Workbook using a different name:
objWBK.SaveAs strSavePathName

' Close Workbook:
objWBK.Close SaveChanges:=False

' My understanding of the requirements is that
' the filename used to save the WorkBook needs
' to be written to the WorkBook template.
' This means that the next time the WorkBook
' is used, the last-used filename will appear
' in next-saved workbook. The following code
' does just that.

' Open WorkBook template again:
Set objWBK = objXL.Workbooks.Open( _
strWorkBookTemplatePath)
Set objWS = objWBK.Worksheets(1)

' Point to where filename is to be written:
Set objRNG1 = objWS.Range(strSaveNameAtCell)

' Write filename into cell in template:
objRNG1.Value = strSaveName

' Save template:
objWBK.Save

' Show finished message:
Call Msg8


Exit_DXReport:

' CLEAN UP AND EXIT

' It's unlikely that an error will be
' encountered in the following exit code.
' However, if an error does occur,
' a means of escape is necessary:
On Error GoTo Abort_CleanUp_DXReport

' Destroy DAO objects:
If Not objRST Is Nothing Then
objRST.Close
Set objRST = Nothing
End If
Set objDB = Nothing

' Destroy Excel objects:
Set objRNG3 = Nothing
Set objRNG2 = Nothing
Set objRNG1 = Nothing
Set objWS = Nothing
If Not objWBK Is Nothing Then
' Don't save changes here!
objWBK.Close SaveChanges:=False
Set objWBK = Nothing
End If
If Not objXL Is Nothing Then
' Quit Excel if we started it:
If fWeStartedExcel Then
objXL.Quit
End If
Set objXL = Nothing
End If

' Destroy File System Object:
Set objFSO = Nothing

Exit Sub

Abort_CleanUp_DXReport:

Exit Sub

Error_DXReport:

MsgBox "Error No: " & Err.Number _
& vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"
Resume Exit_DXReport

End Sub

Private Sub cmdTestMessages_Click()

' This is the click event procedure for
' a command button named cmdTestMessage.
'
' This is used only for testing messages
' during the development phase to make
' sure they display the information you
' want.

Call Msg1
Call Msg2
Call Msg3("r:\temp")
Call Msg4
Call Msg5
Call Msg6
Call Msg7_Test
Call Msg8

End Sub


Private Sub Msg1()

MsgBox "There is no data to write to " _
& "Excel." & vbNewLine _
& "(Recordset is empty.)", _
vbExclamation + vbOKOnly, _
"Report Terminated"

End Sub

Private Sub Msg2()

MsgBox "The Excel template does not exist.", _
vbExclamation + vbOKOnly, _
"Report Terminated"

End Sub


Private Sub Msg3(strSavePath As String)

MsgBox "The following path does " _
& "not exist or is unavailable:" _
& vbNewLine & vbNewLine _
& strSavePath, _
vbExclamation + vbOKOnly, _
"Report Terminated"

End Sub

Private Sub Msg4()

MsgBox "Please enter a valid date for the " _
& "name of the folder where the Excel " _
& "Workbook is to be saved.", _
vbExclamation + vbOKOnly, _
"Report Terminated"

End Sub

Private Sub Msg5()

MsgBox "Please enter a FileName.", _
vbExclamation + vbOKOnly, _
"Report Terminated"

End Sub

Private Sub Msg6()

MsgBox "Cannot save WorkBook. " _
& vbNewLine _
& "(Invalid file name.)", _
vbExclamation + vbOKOnly, _
"Report Terminated"

End Sub

Private Sub Msg7()

MsgBox "The following error occurred while " _
& "cleaning up DX Report processing:" _
& vbNewLine & vbNewLine _
& "Error No: " & CStr(Err.Number) _
& vbNewLine _
& "Description:" & vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"

End Sub

Private Sub Msg7_Test()

On Error GoTo Error_Msg7_Test
Err.Raise 256

Error_Msg7_Test:

MsgBox "The following error occurred while " _
& "cleaning up DX Report processing:" _
& vbNewLine & vbNewLine _
& "Error No: " & CStr(Err.Number) _
& vbNewLine _
& "Description:" & vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"

End Sub

Private Sub Msg8()

MsgBox "Report DX has been created.", _
vbInformation + vbOKOnly, _
"Finished Information"

End Sub

STOP COPYING ON PREVIOUS LINE


Geoff

 

[GeoffG]

Hi Stuart,

I see where you're coming from.
Regards
Geoff

 

[GeoffG]

Hi MLS,

Apologies - missed of the "s".
The name of the TextBox needs to be:
cmdTestMessages
not
cmdTestMessage

Geoff

 

[mls via AccessMonster.com]

Hi Geoff,

Thank you for so much all your hard work over the week-end.
Initially when I ran this it gave me 429 error so I commented the Set objXL,
then it ran fine one time and created a folder witht he report.
When I tried second time with another file name it gave '91' error same as
before..
I included all the references you mentioned.
=======================================
Runtime ERROR 429 "ActiveXComponent can't create object. at line..
Set objXL = GetObject(, "Excel.Application")

When I commented the above line it works fine for one time and when I try to
run again it fails with Run-time Error ‘91’ "Object variable or With block
variable not set". at below block.

With objXL
.Visible = True
.WindowState = xlMinimized
End With
=============================================

 

[mls via AccessMonster.com]

FYI, Currently I am using ACCESS 2000 but eventually will be using 2007. Not
sure Why I get ..
Run-Time Error 429: ActiveX component can't create object because I have
added DAO 3.6, runtime & excel libraries.

Hi Geoff,

Thank you for so much all your hard work over the week-end.
Initially when I ran this it gave me 429 error so I commented the Set objXL,
then it ran fine one time and created a folder witht he report.
When I tried second time with another file name it gave '91' error same as
before..
I included all the references you mentioned.
=======================================
Runtime ERROR 429 "ActiveXComponent can't create object. at line..
Set objXL = GetObject(, "Excel.Application")

When I commented the above line it works fine for one time and when I try to
run again it fails with Run-time Error ‘91’ "Object variable or With block
variable not set". at below block.

With objXL
.Visible = True
.WindowState = xlMinimized
End With
=============================================

Hi MLS,

[quoted text clipped - 5 lines]

Geoff

 

[GeoffG]

Hi MLS,

The code will work fine in Access 2000.

Runtime ERROR 429 "ActiveXComponent can't create object.
at line..
Set objXL = GetObject(, "Excel.Application")

The reason you're getting error 429 is because Excel is not
running when the GetObject() function tries to grab hold of
any running instance of Excel. This error is to be expected
if Excel is not running. That's why the line previous to
GetObject() is On Error Resume Next. VBA will ignore the
error and carry on. The next line after GetObject()
examines whether an error has occurred. If it has, the
CreateObject() function is used instead. The CreateObject()
function doesn't try to grab hold of a running instance of
Excel - instead, it tries to start Excel. If this continues
to be a problem - and I can't see why it should - we'll
recode using the New keyword as suggested by Stuart.

Here's the code (with line numbers):

1 On Error Resume Next
2 Set objXL = GetObject(, "Excel.Application")
3 If Err.Number <> 0 Then
4 On Error GoTo Error_CopyFromRecordsetToXL
5 Set objXL = CreateObject("Excel.Application")
6 End If
7 On Error GoTo Error_CopyFromRecordsetToXL

And here's the explanation of each line (some of this will
be obvious):

Line 1 - Ensures that, if a run-time error occurs on Line 2,
Line 3 will execute.

Line 2 - Attempts to point the objXL variable to an
already-running instance of Excel. If Excel is already
running, no error occurs and objXL points to Excel; if Excel
is not already running an error occurs and objXL points to
nothing.

Line 3 - Examines whether an error occurred on Line 2.
If an error occurred, Lines 4 and 5 execute; if no error
occurred Line 7 executes.

Line 4
Ensures that, if a run-time error occurs on Line 5,
execution will jump to the generic error handler.

Line 5
The CreateObject() function will start a new instance of
Excel and will point the variable objXL to the newly-created
instance.

The objective of the above code is to start Excel
only if necessary. Here's a function that may make things
clearer:


Private Sub GetExcel()

' If Excel is not in memory,
' the GetObject() function will generate
' run-time error 429, in which case we
' need to use the CreateObject() function
' to start Excel.

Dim objXL As Excel.Application

On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If Err.Number = 429 Then
MsgBox "Error No: 429 occurred." _
& vbNewLine _
& "So we need to start a new copy of " _
& "Excel using the CreateObject() " _
& "function." _
& vbNewLine & vbNewLine _
& "Error Description:" _
& vbNewLine _
& Err.Description, _
vbInformation + vbOKOnly, _
"Error Information"
End If

Set objXL = Nothing

End Sub


Geoff

FYI, Currently I am using ACCESS 2000 but eventually will
be using 2007. Not
sure Why I get ..
Run-Time Error 429: ActiveX component can't create object
because I have
added DAO 3.6, runtime & excel libraries.

Hi Geoff,

Thank you for so much all your hard work over the
week-end.
Initially when I ran this it gave me 429 error so I
commented the Set objXL,
then it ran fine one time and created a folder witht he
report.
When I tried second time with another file name it gave
'91' error same as
before..
I included all the references you mentioned.
=======================================
Runtime ERROR 429 "ActiveXComponent can't create object.
at line..
Set objXL = GetObject(, "Excel.Application")

When I commented the above line it works fine for one time
and when I try to
run again it fails with Run-time Error ‘91’ "Object
variable or With block
variable not set". at below block.

With objXL
.Visible = True
.WindowState = xlMinimized
End With
=============================================

Hi MLS,

[quoted text clipped - 5 lines]

Geoff

 

[Stuart McCall]

Hi MLS,

The code will work fine in Access 2000.


The reason you're getting error 429 is because Excel is not running when
the GetObject() function tries to grab hold of any running instance of
Excel. This error is to be expected if Excel is not running. That's why
the line previous to GetObject() is On Error Resume Next. VBA will ignore
the error and carry on. The next line after GetObject() examines whether
an error has occurred. If it has, the CreateObject() function is used
instead. The CreateObject() function doesn't try to grab hold of a
running instance of Excel - instead, it tries to start Excel. If this
continues to be a problem - and I can't see why it should - we'll recode
using the New keyword as suggested by Stuart.

Here's the code (with line numbers):

1 On Error Resume Next
2 Set objXL = GetObject(, "Excel.Application")
3 If Err.Number <> 0 Then
4 On Error GoTo Error_CopyFromRecordsetToXL
5 Set objXL = CreateObject("Excel.Application")
6 End If
7 On Error GoTo Error_CopyFromRecordsetToXL

And here's the explanation of each line (some of this will
be obvious):

Line 1 - Ensures that, if a run-time error occurs on Line 2,
Line 3 will execute.

Line 2 - Attempts to point the objXL variable to an
already-running instance of Excel. If Excel is already
running, no error occurs and objXL points to Excel; if Excel
is not already running an error occurs and objXL points to
nothing.

Line 3 - Examines whether an error occurred on Line 2.
If an error occurred, Lines 4 and 5 execute; if no error
occurred Line 7 executes.

Line 4
Ensures that, if a run-time error occurs on Line 5,
execution will jump to the generic error handler.

Line 5
The CreateObject() function will start a new instance of
Excel and will point the variable objXL to the newly-created
instance.

The objective of the above code is to start Excel
only if necessary. Here's a function that may make things clearer:


Private Sub GetExcel()

' If Excel is not in memory,
' the GetObject() function will generate
' run-time error 429, in which case we
' need to use the CreateObject() function
' to start Excel.

Dim objXL As Excel.Application

On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If Err.Number = 429 Then
MsgBox "Error No: 429 occurred." _
& vbNewLine _
& "So we need to start a new copy of " _
& "Excel using the CreateObject() " _
& "function." _
& vbNewLine & vbNewLine _
& "Error Description:" _
& vbNewLine _
& Err.Description, _
vbInformation + vbOKOnly, _
"Error Information"
End If

Set objXL = Nothing

End Sub


Geoff

If you're having trouble you can try this function. I've used it for years
without a hitch. Note that this is late-bound. The 2nd parameter provides
feedback to the caller re whether the app object had to be created. It's
your choice whether to use the command obj.Activate.

Public Function AppObject(ClassName As String, Optional AppStarted As
Boolean) As Object
Dim obj As Object
'
On Error GoTo AppObject_Err
Set obj = GetObject(, ClassName)
obj.Activate
AppObject_Err:
If Err.Number Then
Err.Clear
Set obj = CreateObject(ClassName)
AppStarted = True
End If
Set AppObject = obj
Set obj = Nothing
End Function

 

[GeoffG]

Thanks Stuart.

I've been wondering whether our friend has omitted the line:
On Error Resume Next.

Incidentally, are you sure your code is OK?

The following line:

On Error GoTo AppObject_Err

sets up a jump to an error handler at the label
"AppObject_Err".

You clear the error generated by GetObject(), which
re-instates the error-handler.

What happens, then, if CreateObject() generates a run-time
error when it can't start the Automation server (perhaps
because it's not installed on the computer)? The error
handler would then cause a jump back to the label and you've
got an infinite loop. It's probably rare that
CreateObject() generates an error because you're always
expecting the server to be present, so it's not something
that's likely to happen. I've never experienced it.
However, it seems that CreateObject() could cause an error,
in which case, you either need to have in-line error
handling still in operation or a jump forwards to a generic
error-handler. What do you think?

All the best.
Geoff

 

[Stuart McCall]

Thanks Stuart.

I've been wondering whether our friend has omitted the line:
On Error Resume Next.

Incidentally, are you sure your code is OK?

The following line:
sets up a jump to an error handler at the label "AppObject_Err".

You clear the error generated by GetObject(), which re-instates the
error-handler.

What happens, then, if CreateObject() generates a run-time error when it
can't start the Automation server (perhaps because it's not installed on
the computer)? The error handler would then cause a jump back to the
label and you've got an infinite loop. It's probably rare that
CreateObject() generates an error because you're always expecting the
server to be present, so it's not something that's likely to happen. I've
never experienced it. However, it seems that CreateObject() could cause an
error, in which case, you either need to have in-line error handling still
in operation or a jump forwards to a generic error-handler. What do you
think?

All the best.
Geoff

Oops. Gave you the wrong version, sorry. You are quite right which is why I
changed it later on. I just went digging in my code library (which I should
have done in the first place) and found the latest:

Public Function AppObject(ClassName As String, Optional AppStarted As
Boolean) As Object
Dim obj As Object
'
On Error Resume Next
Set obj = GetObject(, ClassName)
obj.Activate
If Err.Number Then
Err.Clear
Set obj = CreateObject(ClassName)
AppStarted = True
End If
Set AppObject = obj
Set obj = Nothing
End Function

The way to find whether it was successful or not is to examine the returned
app object. If Null, the function failed.

 

[Stuart McCall]

Correction: the last line ought to read:

If Nothing, the function failed.

 

[GeoffG]

HI Stuart,
Thanks again.
Geoff

 

[mls via AccessMonster.com]

Sorry Geoff, I am still getting the same error again, so I planned to use my
old logic and add the save as option from your logic. I am not sure if ADO or
DAO is better option for this.

Option Compare Database

'Export Results to Excel spreadsheet

Private Sub Command1_Click()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim op As New ADODB.Recordset
Dim dt As New ADODB.Recordset
Dim rfn As New ADODB.Recordset

Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Dim recArray As Variant

Dim strDB As String
Dim fldCount As Integer
Dim recCount As Long

Dim iCol As Integer
Dim iRow As Integer

Const cTabTwo As Byte = 1
DoCmd.Hourglass True

' Set the string to the path of Database
strDB = "c:\temp\strategy.mdb"
sOutput = r:\temp\ResultsReportingWorksheet.xls"
OutFile = "test.xls"

' Open connection to the database
cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strDB & ";"

rst.Open "Select * From ABI_XL", cnt
op.Open "select distinct operator from ABI", cnt
dt.Open "select distinct date_tested from ABI", cnt
rfn.Open "select distinct run_file_name from ABI", cnt

' Create an instance of Excel and add a workbook

Set xlApp = Excel.Application
Set xlWb = xlApp.Workbooks.Open(sOutput)
Set xlWs = xlWb.Worksheets(cTabTwo)


' Display Excel
xlApp.Visible = True
xlApp.UserControl = True

' Copy field names to the worksheet
fldCount = rst.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(20, iCol + 1).Value = rst.Fields(iCol - 1).Name
Next
' Copy the recordset to the worksheet, starting in cell A2
xlWs.Cells(2, 2).CopyFromRecordset op
xlWs.Cells(3, 2).CopyFromRecordset dt
xlWs.Cells(4, 2).CopyFromRecordset rfn
xlWs.Cells(21, 2).CopyFromRecordset rst

' Close ADO objects
rst.Close
op.Close
dt.Close
rfn.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
Set op = Nothing
Set dt = Nothing
Set rfn = Nothing
' Release Excel references
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing

End Sub