Format Excel Sheet after DoCmd.TransferSpreadsheet

  • Thread starter Thread starter John
  • Start date Start date
J

John

I have read through several of the topics on this subject and still don't
seem to have it correct. Will someone give this a quick read and see if you
can spot my problem? Sometimes this runs ok and other times I get odd
errors...

===========
'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlApp.ActiveWorkbook.Worksheets(1)
FlNm = xlApp.ActiveWorkbook.name

'Turn off alerts, macros, screen updating
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False

'Make sure the sheet is active
xlSht.Activate

'Format the worksheet
xlSht.Range("A1").Select
xlSht.Range(Selection,
Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 1
Selection.Font.Bold = True
With Selection.Font
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSht.Cells.Select
xlSht.Cells.EntireColumn.AutoFit
xlSht.Range("A2").Select
ActiveWindow.FreezePanes = True
xlSht.Range("A1").Select
xlSht.Range(Selection,
ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
xlSht.Range("A2").Select

'Rename the sheet to the file name.
Sheets(1).name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlApp.ActiveWorkbook.Save
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

==========

I was also having trouble getting the excel application to close all the
way. You can see it if you look in the task manager.
 
You don't say what the random errors are, so it's a bit difficult to spot
where in the code they might be generated. However, I see that you're using
the EXCEL intrinsic constant xlLastCell, which has NO meaning in your ACCESS
VBA code because you're using late binding for EXCEL. The actual value of
xlLastCell is 11, so replace the xlLastCell with the number 11 in your code.

Whenever you use "Active"... something in your code, you're likely to have
an instance of EXCEL remaining when your code ends. Use of these special
objects can cause ACCESS to instantiate another instance of EXCEL to
reference them. Just use the objects that you're already using for sheet,
workbook, etc. Forget about the Active... stuff. I do note that your code is
going through your xlApp object to get to these Active... objects, so they
may not be the actual cause of your extra EXCEL session.

This line of code
xlSht.Range(Selection, Selection.End(xlToRight)).Select

is using an unreferenced object (Selection), which also can cause another
instantiation of EXCEL.

See this Knowledge Base article for more details about qualifying objects in
VBA automation:
Excel automation fails second time code runs
http://support.microsoft.com/kb/178510/en-us

--

Ken Snell
http://www.accessmvp.com/KDSnell/
 
This is how I would write the code.

'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlWkb.Worksheets(1)
FlNm = xlWkb.name

'Format the worksheet
with xlSht.Range("A1:<End of the range>")
with .Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
end with

xlSht.columns.autofit
xlSht.Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True

xlSht.Range("A1:<end of column>").AutoFilter

'Rename the sheet to the file name.
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlWkb.Save

Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
 
Ken,

You are correct... sorry. The error I am getting is:

Runtime error '462':
The remote server machine does not exist or is unavailable.

I guess you can tell from my code that I am new to all this. I don't know
what "late binding" is or intrinsic constants! I just search for answers and
copy code! Sometimes it works, sometimes I am not so lucky. Lucky for me
resources such as yourself are willing to help.


I am testing out "tbs" response...
 
tbs:

Thanks for the code modifications. It does present me with two problems:

1. The number of fields in the query the user selects is unknown until they
select them. They pick available reporting options from a picklist, then
select the output (Excel, Report, Screen). The excel output is what I am
currently working on. Some of the queries have a few columns, some have up
to 50. I tried to solve this problem with this:

'Get the number of fields in the selected query...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim FldCnt As Integer

Set db = Access.CurrentDb
Set qry = db.QueryDefs(RunQry)
Set rs = qry.OpenRecordset

FldCnt = rs.Fields.Count

Set qry = Nothing
Set rs = Nothing
Set db = Nothing

The problems is the line "Set qry = db.QueryDefs(RunQry)". Access doesn't
like it. RunQry is a string variable with a query name in it "Activity
Mapping Review" is an example. I have tried several variations and get
errors. " Runtime error '3265' Item not found in this collection. I have
also tried Set qry = db.QueryDefs(""" & RunQry & """) and Set qry =
db.QueryDefs("RunQry"). I then get errors on the Set rs = qry.OpenRecordset
line.

2. Once I know the field count, how do i reference it in the range
statement? I have tried setting a string 'HdeRng = "A1:A" & Format(FldCnt,
"##0) and it creates a variable A1:A11 for example. But how is this used?
xlSht.Range(HdrRng).Select does not work. I also tried, xlSht.Range(Cells(1,
1), Cells(1, FldCnt)).Select


Sorry to be a bother...
 
A little more - RunQry is a string variable with the name of the query. When
the user selects the "Screen" output option I use:

DoCmd.OpenQuery RunQry, acViewNormal, acReadOnly

to show it to them.

The RunQry string, does not have a sql statement in it, just the name of the
query.
 
Information about early and late binding, and intrinsic constants (intrinsic
constants are hard-coded constants -- built into VBA code by Microsoft --
that look like variables; in EXCEL they start with xl, in ACCESS they start
with ac, etc.; they're meant to be used as short-hand, "the name tells you
what it stands for" substitutes for using the actual integer values that
otherwise you'd need to remember for the arguments of functions and methods
and subroutines that are built into VBA):

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

http://www.granite.ab.ca/access/latebinding.htm

http://www.dicks-clicks.com/excel/olBinding.htm

--

Ken Snell
http://www.accessmvp.com/KDSnell/
 
1. ok, how about trying this...

Dim rs As DAO.Recordset

Set rs = currentdb.openrecordset("Select top 1 * from [" & RunQry & "]")
FldCnt = rs.Fields.Count

Set rs = Nothing

2. Not sure how well do you know about excel range, you can try doing this.

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, fldcnt).Address
xlSht.Range("A1:" & sEndColumn).Select
 
TBS,

Thanks for the additional support... I am getting an error I can't seem to
figure out on the rs statement:

Set rs = CurrentDb.OpenRecordset("Select top 1 * from [" & RunQry & "]")

The error is:

Runtime Error '3061' Too few parameters. Expected 2.

Any ideas?
--
Thanks in advance!
**John**


tbs said:
1. ok, how about trying this...

Dim rs As DAO.Recordset

Set rs = currentdb.openrecordset("Select top 1 * from [" & RunQry & "]")
FldCnt = rs.Fields.Count

Set rs = Nothing

2. Not sure how well do you know about excel range, you can try doing this.

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, fldcnt).Address
xlSht.Range("A1:" & sEndColumn).Select

John said:
tbs:

Thanks for the code modifications. It does present me with two problems:

1. The number of fields in the query the user selects is unknown until they
select them. They pick available reporting options from a picklist, then
select the output (Excel, Report, Screen). The excel output is what I am
currently working on. Some of the queries have a few columns, some have up
to 50. I tried to solve this problem with this:

'Get the number of fields in the selected query...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim FldCnt As Integer

Set db = Access.CurrentDb
Set qry = db.QueryDefs(RunQry)
Set rs = qry.OpenRecordset

FldCnt = rs.Fields.Count

Set qry = Nothing
Set rs = Nothing
Set db = Nothing

The problems is the line "Set qry = db.QueryDefs(RunQry)". Access doesn't
like it. RunQry is a string variable with a query name in it "Activity
Mapping Review" is an example. I have tried several variations and get
errors. " Runtime error '3265' Item not found in this collection. I have
also tried Set qry = db.QueryDefs(""" & RunQry & """) and Set qry =
db.QueryDefs("RunQry"). I then get errors on the Set rs = qry.OpenRecordset
line.

2. Once I know the field count, how do i reference it in the range
statement? I have tried setting a string 'HdeRng = "A1:A" & Format(FldCnt,
"##0) and it creates a variable A1:A11 for example. But how is this used?
xlSht.Range(HdrRng).Select does not work. I also tried, xlSht.Range(Cells(1,
1), Cells(1, FldCnt)).Select


Sorry to be a bother...
Click to expand...
Click to expand...
 
is your query a parameterize query? if that's the case, you can't use
"select... from runqry". you have to use querydef.

example:
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qd As DAO.QueryDef
Set dbs = CurrentDb
Set qd = dbs.QueryDefs(RunQry)
qd.Parameters![YourParm1] = "SomeValue"
qd.Parameters![YourParm2] = "SomeValue"
Set rst = qd.OpenRecordset

alternatively, try using other method rather than parameterize query.

John said:
TBS,

Thanks for the additional support... I am getting an error I can't seem to
figure out on the rs statement:

Set rs = CurrentDb.OpenRecordset("Select top 1 * from [" & RunQry & "]")

The error is:

Runtime Error '3061' Too few parameters. Expected 2.

Any ideas?
--
Thanks in advance!
**John**


tbs said:
1. ok, how about trying this...

Dim rs As DAO.Recordset

Set rs = currentdb.openrecordset("Select top 1 * from [" & RunQry & "]")
FldCnt = rs.Fields.Count

Set rs = Nothing

2. Not sure how well do you know about excel range, you can try doing this.

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, fldcnt).Address
xlSht.Range("A1:" & sEndColumn).Select

John said:
tbs:

Thanks for the code modifications. It does present me with two problems:

1. The number of fields in the query the user selects is unknown until they
select them. They pick available reporting options from a picklist, then
select the output (Excel, Report, Screen). The excel output is what I am
currently working on. Some of the queries have a few columns, some have up
to 50. I tried to solve this problem with this:

'Get the number of fields in the selected query...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim FldCnt As Integer

Set db = Access.CurrentDb
Set qry = db.QueryDefs(RunQry)
Set rs = qry.OpenRecordset

FldCnt = rs.Fields.Count

Set qry = Nothing
Set rs = Nothing
Set db = Nothing

The problems is the line "Set qry = db.QueryDefs(RunQry)". Access doesn't
like it. RunQry is a string variable with a query name in it "Activity
Mapping Review" is an example. I have tried several variations and get
errors. " Runtime error '3265' Item not found in this collection. I have
also tried Set qry = db.QueryDefs(""" & RunQry & """) and Set qry =
db.QueryDefs("RunQry"). I then get errors on the Set rs = qry.OpenRecordset
line.

2. Once I know the field count, how do i reference it in the range
statement? I have tried setting a string 'HdeRng = "A1:A" & Format(FldCnt,
"##0) and it creates a variable A1:A11 for example. But how is this used?
xlSht.Range(HdrRng).Select does not work. I also tried, xlSht.Range(Cells(1,
1), Cells(1, FldCnt)).Select


Sorry to be a bother...

--
Thanks in advance!
**John**


:

This is how I would write the code.

'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlWkb.Worksheets(1)
FlNm = xlWkb.name

As for here it's abit tricky. I wouldn't recommend using Selection . I would prefer getting the exact range. I think it shouldn't be difficult to know where's the end of the column and rows by doing a simple count on the query.

'Format the worksheet
with xlSht.Range("A1:<End of the range>")
with .Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
end with

xlSht.columns.autofit
xlSht.Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True

xlSht.Range("A1:<end of column>").AutoFilter

'Rename the sheet to the file name.
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlWkb.Save

Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
:

I have read through several of the topics on this subject and still don't
seem to have it correct. Will someone give this a quick read and see if you
can spot my problem? Sometimes this runs ok and other times I get odd
errors...

===========
'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlApp.ActiveWorkbook.Worksheets(1)
FlNm = xlApp.ActiveWorkbook.name

'Turn off alerts, macros, screen updating
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False

'Make sure the sheet is active
xlSht.Activate

'Format the worksheet
xlSht.Range("A1").Select
xlSht.Range(Selection,
Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 1
Selection.Font.Bold = True
With Selection.Font
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSht.Cells.Select
xlSht.Cells.EntireColumn.AutoFit
xlSht.Range("A2").Select
ActiveWindow.FreezePanes = True
xlSht.Range("A1").Select
xlSht.Range(Selection,
ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
xlSht.Range("A2").Select

'Rename the sheet to the file name.
Sheets(1).name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlApp.ActiveWorkbook.Save
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

==========

I was also having trouble getting the excel application to close all the
way. You can see it if you look in the task manager.
Click to expand...
Click to expand...
Click to expand...
 
TBS - I'll work on this and see what I come up with. Thanks for hanging in
there with me.... I see a problem coming up... Some of the queries require
one parameter and some two. There are 4 dates on a form the user picks
before running the query. Some of the queries use no parameters, some use
one, some use two, none of them use 3 or more (yet).

Other than doing a case select statement for each query (30+ and growing),
is there a way to find how how many parameters are needed, and what they are
before doing:
qd = dbs.QueryDefs(RunQry)
qd.Paramerers![pname1] = me.form.CmbCurProj
qd.Paramerers![pname2] = me.form.CmbPriProj
Set rst = qd.OpenRecordset


--
Thanks in advance!
**John**


tbs said:
is your query a parameterize query? if that's the case, you can't use
"select... from runqry". you have to use querydef.

example:
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qd As DAO.QueryDef
Set dbs = CurrentDb
Set qd = dbs.QueryDefs(RunQry)
qd.Parameters![YourParm1] = "SomeValue"
qd.Parameters![YourParm2] = "SomeValue"
Set rst = qd.OpenRecordset

alternatively, try using other method rather than parameterize query.

John said:
TBS,

Thanks for the additional support... I am getting an error I can't seem to
figure out on the rs statement:

Set rs = CurrentDb.OpenRecordset("Select top 1 * from [" & RunQry & "]")

The error is:

Runtime Error '3061' Too few parameters. Expected 2.

Any ideas?
--
Thanks in advance!
**John**


tbs said:
1. ok, how about trying this...

Dim rs As DAO.Recordset

Set rs = currentdb.openrecordset("Select top 1 * from [" & RunQry & "]")
FldCnt = rs.Fields.Count

Set rs = Nothing

2. Not sure how well do you know about excel range, you can try doing this.

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, fldcnt).Address
xlSht.Range("A1:" & sEndColumn).Select

:

tbs:

Thanks for the code modifications. It does present me with two problems:

1. The number of fields in the query the user selects is unknown until they
select them. They pick available reporting options from a picklist, then
select the output (Excel, Report, Screen). The excel output is what I am
currently working on. Some of the queries have a few columns, some have up
to 50. I tried to solve this problem with this:

'Get the number of fields in the selected query...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim FldCnt As Integer

Set db = Access.CurrentDb
Set qry = db.QueryDefs(RunQry)
Set rs = qry.OpenRecordset

FldCnt = rs.Fields.Count

Set qry = Nothing
Set rs = Nothing
Set db = Nothing

The problems is the line "Set qry = db.QueryDefs(RunQry)". Access doesn't
like it. RunQry is a string variable with a query name in it "Activity
Mapping Review" is an example. I have tried several variations and get
errors. " Runtime error '3265' Item not found in this collection. I have
also tried Set qry = db.QueryDefs(""" & RunQry & """) and Set qry =
db.QueryDefs("RunQry"). I then get errors on the Set rs = qry.OpenRecordset
line.

2. Once I know the field count, how do i reference it in the range
statement? I have tried setting a string 'HdeRng = "A1:A" & Format(FldCnt,
"##0) and it creates a variable A1:A11 for example. But how is this used?
xlSht.Range(HdrRng).Select does not work. I also tried, xlSht.Range(Cells(1,
1), Cells(1, FldCnt)).Select


Sorry to be a bother...

--
Thanks in advance!
**John**


:

This is how I would write the code.

'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlWkb.Worksheets(1)
FlNm = xlWkb.name

As for here it's abit tricky. I wouldn't recommend using Selection . I would prefer getting the exact range. I think it shouldn't be difficult to know where's the end of the column and rows by doing a simple count on the query.

'Format the worksheet
with xlSht.Range("A1:<End of the range>")
with .Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
end with

xlSht.columns.autofit
xlSht.Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True

xlSht.Range("A1:<end of column>").AutoFilter

'Rename the sheet to the file name.
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlWkb.Save

Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
:

I have read through several of the topics on this subject and still don't
seem to have it correct. Will someone give this a quick read and see if you
can spot my problem? Sometimes this runs ok and other times I get odd
errors...

===========
'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlApp.ActiveWorkbook.Worksheets(1)
FlNm = xlApp.ActiveWorkbook.name

'Turn off alerts, macros, screen updating
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False

'Make sure the sheet is active
xlSht.Activate

'Format the worksheet
xlSht.Range("A1").Select
xlSht.Range(Selection,
Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 1
Selection.Font.Bold = True
With Selection.Font
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSht.Cells.Select
xlSht.Cells.EntireColumn.AutoFit
xlSht.Range("A2").Select
ActiveWindow.FreezePanes = True
xlSht.Range("A1").Select
xlSht.Range(Selection,
ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
xlSht.Range("A2").Select

'Rename the sheet to the file name.
Sheets(1).name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlApp.ActiveWorkbook.Save
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

==========

I was also having trouble getting the excel application to close all the
way. You can see it if you look in the task manager.
Click to expand...
Click to expand...
Click to expand...
 
if that's the case, I'll recommend you another way of doing it. It's abit
silly but it'll work. :)

dim iCol as integer

iCol = 1
do while not nz(xlSht(1, iCol), "") = ""
iCol = iCol + 1
loop

' You can ommit this if you are confident that there's at least 1 column of
data in your worksheet.
if iCol > 1 then
iCol = iCol - 1
end if

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, iCol).Address
xlSht.Range("A1:" & sEndColumn).Select

John said:
TBS - I'll work on this and see what I come up with. Thanks for hanging in
there with me.... I see a problem coming up... Some of the queries require
one parameter and some two. There are 4 dates on a form the user picks
before running the query. Some of the queries use no parameters, some use
one, some use two, none of them use 3 or more (yet).

Other than doing a case select statement for each query (30+ and growing),
is there a way to find how how many parameters are needed, and what they are
before doing:
qd = dbs.QueryDefs(RunQry)
qd.Paramerers![pname1] = me.form.CmbCurProj
qd.Paramerers![pname2] = me.form.CmbPriProj
Set rst = qd.OpenRecordset


--
Thanks in advance!
**John**


tbs said:
is your query a parameterize query? if that's the case, you can't use
"select... from runqry". you have to use querydef.

example:
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qd As DAO.QueryDef
Set dbs = CurrentDb
Set qd = dbs.QueryDefs(RunQry)
qd.Parameters![YourParm1] = "SomeValue"
qd.Parameters![YourParm2] = "SomeValue"
Set rst = qd.OpenRecordset

alternatively, try using other method rather than parameterize query.

John said:
TBS,

Thanks for the additional support... I am getting an error I can't seem to
figure out on the rs statement:

Set rs = CurrentDb.OpenRecordset("Select top 1 * from [" & RunQry & "]")

The error is:

Runtime Error '3061' Too few parameters. Expected 2.

Any ideas?
--
Thanks in advance!
**John**


:

1. ok, how about trying this...

Dim rs As DAO.Recordset

Set rs = currentdb.openrecordset("Select top 1 * from [" & RunQry & "]")
FldCnt = rs.Fields.Count

Set rs = Nothing

2. Not sure how well do you know about excel range, you can try doing this.

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, fldcnt).Address
xlSht.Range("A1:" & sEndColumn).Select

:

tbs:

Thanks for the code modifications. It does present me with two problems:

1. The number of fields in the query the user selects is unknown until they
select them. They pick available reporting options from a picklist, then
select the output (Excel, Report, Screen). The excel output is what I am
currently working on. Some of the queries have a few columns, some have up
to 50. I tried to solve this problem with this:

'Get the number of fields in the selected query...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim FldCnt As Integer

Set db = Access.CurrentDb
Set qry = db.QueryDefs(RunQry)
Set rs = qry.OpenRecordset

FldCnt = rs.Fields.Count

Set qry = Nothing
Set rs = Nothing
Set db = Nothing

The problems is the line "Set qry = db.QueryDefs(RunQry)". Access doesn't
like it. RunQry is a string variable with a query name in it "Activity
Mapping Review" is an example. I have tried several variations and get
errors. " Runtime error '3265' Item not found in this collection. I have
also tried Set qry = db.QueryDefs(""" & RunQry & """) and Set qry =
db.QueryDefs("RunQry"). I then get errors on the Set rs = qry.OpenRecordset
line.

2. Once I know the field count, how do i reference it in the range
statement? I have tried setting a string 'HdeRng = "A1:A" & Format(FldCnt,
"##0) and it creates a variable A1:A11 for example. But how is this used?
xlSht.Range(HdrRng).Select does not work. I also tried, xlSht.Range(Cells(1,
1), Cells(1, FldCnt)).Select


Sorry to be a bother...

--
Thanks in advance!
**John**


:

This is how I would write the code.

'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlWkb.Worksheets(1)
FlNm = xlWkb.name

As for here it's abit tricky. I wouldn't recommend using Selection . I would prefer getting the exact range. I think it shouldn't be difficult to know where's the end of the column and rows by doing a simple count on the query.

'Format the worksheet
with xlSht.Range("A1:<End of the range>")
with .Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
end with

xlSht.columns.autofit
xlSht.Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True

xlSht.Range("A1:<end of column>").AutoFilter

'Rename the sheet to the file name.
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlWkb.Save

Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
:

I have read through several of the topics on this subject and still don't
seem to have it correct. Will someone give this a quick read and see if you
can spot my problem? Sometimes this runs ok and other times I get odd
errors...

===========
'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlApp.ActiveWorkbook.Worksheets(1)
FlNm = xlApp.ActiveWorkbook.name

'Turn off alerts, macros, screen updating
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False

'Make sure the sheet is active
xlSht.Activate

'Format the worksheet
xlSht.Range("A1").Select
xlSht.Range(Selection,
Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 1
Selection.Font.Bold = True
With Selection.Font
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSht.Cells.Select
xlSht.Cells.EntireColumn.AutoFit
xlSht.Range("A2").Select
ActiveWindow.FreezePanes = True
xlSht.Range("A1").Select
xlSht.Range(Selection,
ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
xlSht.Range("A2").Select

'Rename the sheet to the file name.
Sheets(1).name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlApp.ActiveWorkbook.Save
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

==========

I was also having trouble getting the excel application to close all the
way. You can see it if you look in the task manager.
Click to expand...
Click to expand...
Click to expand...
 
TBS - sorry it's taken so long... I took another approach. The problem is
that the Excel Application will not close! Everything else seems to be
working although it's not fully tested. If you can spot why Excel will not
close, it would be a great help.
=========
'Generic query output to Excel...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case "[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case "[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case "[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case "[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking for" &
qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.ActiveSheet
xlWkb.SaveAs fn 'fn is a string variable that is populated with the full
path and filename the user supplied...
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlRng.Select
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
=========
--
Thanks in advance!
**John**


tbs said:
if that's the case, I'll recommend you another way of doing it. It's abit
silly but it'll work. :)

dim iCol as integer

iCol = 1
do while not nz(xlSht(1, iCol), "") = ""
iCol = iCol + 1
loop

' You can ommit this if you are confident that there's at least 1 column of
data in your worksheet.
if iCol > 1 then
iCol = iCol - 1
end if

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, iCol).Address
xlSht.Range("A1:" & sEndColumn).Select

John said:
TBS - I'll work on this and see what I come up with. Thanks for hanging in
there with me.... I see a problem coming up... Some of the queries require
one parameter and some two. There are 4 dates on a form the user picks
before running the query. Some of the queries use no parameters, some use
one, some use two, none of them use 3 or more (yet).

Other than doing a case select statement for each query (30+ and growing),
is there a way to find how how many parameters are needed, and what they are
before doing:
qd = dbs.QueryDefs(RunQry)
qd.Paramerers![pname1] = me.form.CmbCurProj
qd.Paramerers![pname2] = me.form.CmbPriProj
Set rst = qd.OpenRecordset


--
Thanks in advance!
**John**


tbs said:
is your query a parameterize query? if that's the case, you can't use
"select... from runqry". you have to use querydef.

example:
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qd As DAO.QueryDef
Set dbs = CurrentDb
Set qd = dbs.QueryDefs(RunQry)
qd.Parameters![YourParm1] = "SomeValue"
qd.Parameters![YourParm2] = "SomeValue"
Set rst = qd.OpenRecordset

alternatively, try using other method rather than parameterize query.

:

TBS,

Thanks for the additional support... I am getting an error I can't seem to
figure out on the rs statement:

Set rs = CurrentDb.OpenRecordset("Select top 1 * from [" & RunQry & "]")

The error is:

Runtime Error '3061' Too few parameters. Expected 2.

Any ideas?
--
Thanks in advance!
**John**


:

1. ok, how about trying this...

Dim rs As DAO.Recordset

Set rs = currentdb.openrecordset("Select top 1 * from [" & RunQry & "]")
FldCnt = rs.Fields.Count

Set rs = Nothing

2. Not sure how well do you know about excel range, you can try doing this.

dim sEndColumn as string
sEndcolumn = xlSht.cells(1, fldcnt).Address
xlSht.Range("A1:" & sEndColumn).Select

:

tbs:

Thanks for the code modifications. It does present me with two problems:

1. The number of fields in the query the user selects is unknown until they
select them. They pick available reporting options from a picklist, then
select the output (Excel, Report, Screen). The excel output is what I am
currently working on. Some of the queries have a few columns, some have up
to 50. I tried to solve this problem with this:

'Get the number of fields in the selected query...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim FldCnt As Integer

Set db = Access.CurrentDb
Set qry = db.QueryDefs(RunQry)
Set rs = qry.OpenRecordset

FldCnt = rs.Fields.Count

Set qry = Nothing
Set rs = Nothing
Set db = Nothing

The problems is the line "Set qry = db.QueryDefs(RunQry)". Access doesn't
like it. RunQry is a string variable with a query name in it "Activity
Mapping Review" is an example. I have tried several variations and get
errors. " Runtime error '3265' Item not found in this collection. I have
also tried Set qry = db.QueryDefs(""" & RunQry & """) and Set qry =
db.QueryDefs("RunQry"). I then get errors on the Set rs = qry.OpenRecordset
line.

2. Once I know the field count, how do i reference it in the range
statement? I have tried setting a string 'HdeRng = "A1:A" & Format(FldCnt,
"##0) and it creates a variable A1:A11 for example. But how is this used?
xlSht.Range(HdrRng).Select does not work. I also tried, xlSht.Range(Cells(1,
1), Cells(1, FldCnt)).Select


Sorry to be a bother...

--
Thanks in advance!
**John**


:

This is how I would write the code.

'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlWkb.Worksheets(1)
FlNm = xlWkb.name

As for here it's abit tricky. I wouldn't recommend using Selection . I would prefer getting the exact range. I think it shouldn't be difficult to know where's the end of the column and rows by doing a simple count on the query.

'Format the worksheet
with xlSht.Range("A1:<End of the range>")
with .Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
end with

xlSht.columns.autofit
xlSht.Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True

xlSht.Range("A1:<end of column>").AutoFilter

'Rename the sheet to the file name.
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlWkb.Save

Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
:

I have read through several of the topics on this subject and still don't
seem to have it correct. Will someone give this a quick read and see if you
can spot my problem? Sometimes this runs ok and other times I get odd
errors...

===========
'Run the selected query out to excel...
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, RunQry, fn, True

'Format the spreadsheet
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSht As Object
Dim FlNm As String 'Just the name of the file.

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWkb = xlApp.Workbooks.Open(fn) ' "fn" is the name
with path.
Set xlSht = xlApp.ActiveWorkbook.Worksheets(1)
FlNm = xlApp.ActiveWorkbook.name

'Turn off alerts, macros, screen updating
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False

'Make sure the sheet is active
xlSht.Activate

'Format the worksheet
xlSht.Range("A1").Select
xlSht.Range(Selection,
Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 1
Selection.Font.Bold = True
With Selection.Font
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSht.Cells.Select
xlSht.Cells.EntireColumn.AutoFit
xlSht.Range("A2").Select
ActiveWindow.FreezePanes = True
xlSht.Range("A1").Select
xlSht.Range(Selection,
ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
xlSht.Range("A2").Select

'Rename the sheet to the file name.
Sheets(1).name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Save the workbook, clean-up, and exit
xlApp.ActiveWorkbook.Save
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
Click to expand...
Click to expand...
Click to expand...
 
Hi John,

I've tried to simulate your codes at my side and managed to find out the
cause to your problem.

change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

change:
ActiveWindow.FreezePanes = True
to:
xlApp.ActiveWindow.FreezePanes = True

Note that you have to be very specific and careful when you are using
"Active..." as it may go haywire at some point of your program. I would
advise you to avoid using it unless you have no other choices.

John said:
TBS - sorry it's taken so long... I took another approach. The problem is
that the Excel Application will not close! Everything else seems to be
working although it's not fully tested. If you can spot why Excel will not
close, it would be a great help.
=========
'Generic query output to Excel...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case "[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case "[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case "[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case "[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking for" &
qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.ActiveSheet
xlWkb.SaveAs fn 'fn is a string variable that is populated with the full
path and filename the user supplied...
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlRng.Select
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
=========
Click to expand...
 
TBS...

Feels like we are getting close. I am now getting the following error:

Run-time error: '462'
The remote server machine does not exist or is unavailable.

This occurs on the line after "xlApp.ActiveWindow.FreezePanes = True" which
is:

xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter

searching help doesn't help much...

Thanks again.

--
Thanks in advance!
**John**


tbs said:
Hi John,

I've tried to simulate your codes at my side and managed to find out the
cause to your problem.

change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

change:
ActiveWindow.FreezePanes = True
to:
xlApp.ActiveWindow.FreezePanes = True

Note that you have to be very specific and careful when you are using
"Active..." as it may go haywire at some point of your program. I would
advise you to avoid using it unless you have no other choices.

John said:
TBS - sorry it's taken so long... I took another approach. The problem is
that the Excel Application will not close! Everything else seems to be
working although it's not fully tested. If you can spot why Excel will not
close, it would be a great help.
=========
'Generic query output to Excel...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case "[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case "[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case "[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case "[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking for" &
qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.ActiveSheet
xlWkb.SaveAs fn 'fn is a string variable that is populated with the full
path and filename the user supplied...
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlRng.Select
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
=========
Click to expand...
Click to expand...
 
did you do this?
change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

I also got the same error initially but not after i've made the changes above.

John said:
TBS...

Feels like we are getting close. I am now getting the following error:

Run-time error: '462'
The remote server machine does not exist or is unavailable.

This occurs on the line after "xlApp.ActiveWindow.FreezePanes = True" which
is:

xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter

searching help doesn't help much...

Thanks again.

--
Thanks in advance!
**John**


tbs said:
Hi John,

I've tried to simulate your codes at my side and managed to find out the
cause to your problem.

change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

change:
ActiveWindow.FreezePanes = True
to:
xlApp.ActiveWindow.FreezePanes = True

Note that you have to be very specific and careful when you are using
"Active..." as it may go haywire at some point of your program. I would
advise you to avoid using it unless you have no other choices.

John said:
TBS - sorry it's taken so long... I took another approach. The problem is
that the Excel Application will not close! Everything else seems to be
working although it's not fully tested. If you can spot why Excel will not
close, it would be a great help.
=========
'Generic query output to Excel...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case "[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case "[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case "[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case "[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking for" &
qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.ActiveSheet
xlWkb.SaveAs fn 'fn is a string variable that is populated with the full
path and filename the user supplied...
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlRng.Select
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
=========
Click to expand...
Click to expand...
Click to expand...
 
Yes I did... I check it over again to see if I had a typo... I don't see one,
perhaps you can spot it...
++++++++++++++
'This is the default for generic Excel output...

'Dimention Database an Spreadsheet variabls...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case
"[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case
"[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case
"[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case
"[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking
for" & qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.Sheets(1)
xlWkb.SaveAs fn
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlApp.ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

++++++++++++++
--
Thanks in advance!
**John**


tbs said:
did you do this?
change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

I also got the same error initially but not after i've made the changes above.

John said:
TBS...

Feels like we are getting close. I am now getting the following error:

Run-time error: '462'
The remote server machine does not exist or is unavailable.

This occurs on the line after "xlApp.ActiveWindow.FreezePanes = True" which
is:

xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter

searching help doesn't help much...

Thanks again.

--
Thanks in advance!
**John**


tbs said:
Hi John,

I've tried to simulate your codes at my side and managed to find out the
cause to your problem.

change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

change:
ActiveWindow.FreezePanes = True
to:
xlApp.ActiveWindow.FreezePanes = True

Note that you have to be very specific and careful when you are using
"Active..." as it may go haywire at some point of your program. I would
advise you to avoid using it unless you have no other choices.

:

TBS - sorry it's taken so long... I took another approach. The problem is
that the Excel Application will not close! Everything else seems to be
working although it's not fully tested. If you can spot why Excel will not
close, it would be a great help.
=========
'Generic query output to Excel...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case "[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case "[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case "[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case "[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking for" &
qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.ActiveSheet
xlWkb.SaveAs fn 'fn is a string variable that is populated with the full
path and filename the user supplied...
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlRng.Select
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
=========
Click to expand...
Click to expand...
Click to expand...
 
yeah, I think I've spotted something.

xlSht.Columns.AutoFit
xlRng.Select ' <== insert this line before freeze panel.
xlApp.ActiveWindow.FreezePanes = True


John said:
Yes I did... I check it over again to see if I had a typo... I don't see one,
perhaps you can spot it...
++++++++++++++
'This is the default for generic Excel output...

'Dimention Database an Spreadsheet variabls...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case
"[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case
"[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case
"[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case
"[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking
for" & qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.Sheets(1)
xlWkb.SaveAs fn
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlApp.ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

++++++++++++++
--
Thanks in advance!
**John**


tbs said:
did you do this?
change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

I also got the same error initially but not after i've made the changes above.

John said:
TBS...

Feels like we are getting close. I am now getting the following error:

Run-time error: '462'
The remote server machine does not exist or is unavailable.

This occurs on the line after "xlApp.ActiveWindow.FreezePanes = True" which
is:

xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter

searching help doesn't help much...

Thanks again.

--
Thanks in advance!
**John**


:

Hi John,

I've tried to simulate your codes at my side and managed to find out the
cause to your problem.

change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

change:
ActiveWindow.FreezePanes = True
to:
xlApp.ActiveWindow.FreezePanes = True

Note that you have to be very specific and careful when you are using
"Active..." as it may go haywire at some point of your program. I would
advise you to avoid using it unless you have no other choices.

:

TBS - sorry it's taken so long... I took another approach. The problem is
that the Excel Application will not close! Everything else seems to be
working although it's not fully tested. If you can spot why Excel will not
close, it would be a great help.
=========
'Generic query output to Excel...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case "[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case "[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case "[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case "[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking for" &
qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.ActiveSheet
xlWkb.SaveAs fn 'fn is a string variable that is populated with the full
path and filename the user supplied...
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlRng.Select
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Click to expand...
Click to expand...
Click to expand...
 
TBS - this has got to the the most frustrating problem!!! Here's where I
stand:
1. The code will run fine, one time except it leaves EXCEL.EXE running.
2. The next time I run the code, it will give me the '462' mentioned bellow.
3. If I kill Excel, delete the output files, and run the code again, I am
back to #1 above.

In an effort to figure out the problem, I did some code changes... didn't
help much but here's where I stand (not all the code... just starts were the
issues show up):

'==========>

FCnt = rs.Fields.Count
RCnt = rs.RecordCount

Set xlRng = xlSht.Cells(2, 1)
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
xlApp.ActiveWindow.FreezePanes = True
'**** the line below is where the error shows up...
Set xlRng = xlSht.Range(Cells(1, 1), Cells(RCnt + 1,
FCnt))
xlRng.Select
xlRng.AutoFilter
Set xlRng = xlSht.Range(Cells(2, 1), Cells(RCnt + 1,
FCnt))
xlRng.Select
With xlRng
.Font.name = "Arial"
.Font.Size = 8
End With
Set xlRng = xlSht.Cells(2, 1)
xlRng.Select
'**** Why isn't ".name" capitized like ".Name" in the line below?
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

'Display the spreadsheet?
If MsgBox("Do you want to see the exported data?",
vbYesNo + vbQuestion, "View Now?") = vbYes Then
FollowHyperlink fn
End If
End Select
'==========>

Sorry this is not working out and I'll buy you a beer (or two!) should the
opportunity ever present itself!

--
Thanks in advance!
**John**


tbs said:
yeah, I think I've spotted something.

xlSht.Columns.AutoFit
xlRng.Select ' <== insert this line before freeze panel.
xlApp.ActiveWindow.FreezePanes = True


John said:
Yes I did... I check it over again to see if I had a typo... I don't see one,
perhaps you can spot it...
++++++++++++++
'This is the default for generic Excel output...

'Dimention Database an Spreadsheet variabls...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case
"[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case
"[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case
"[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case
"[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking
for" & qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.Sheets(1)
xlWkb.SaveAs fn
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlApp.ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.Size = 8
xlWkb.Save

'Clean-up, and exit
rs.Close
qry.Close
Set fld = Nothing
Set rs = Nothing
Set qry = Nothing
Set db = Nothing
Set xlRng = Nothing
Set xlSht = Nothing
xlWkb.Close
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing

++++++++++++++
--
Thanks in advance!
**John**


tbs said:
did you do this?
change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

I also got the same error initially but not after i've made the changes above.

:

TBS...

Feels like we are getting close. I am now getting the following error:

Run-time error: '462'
The remote server machine does not exist or is unavailable.

This occurs on the line after "xlApp.ActiveWindow.FreezePanes = True" which
is:

xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter

searching help doesn't help much...

Thanks again.

--
Thanks in advance!
**John**


:

Hi John,

I've tried to simulate your codes at my side and managed to find out the
cause to your problem.

change:
Set xlSht = xlWkb.ActiveSheet
to:
Set xlSht = xlWkb.sheets(1)

change:
ActiveWindow.FreezePanes = True
to:
xlApp.ActiveWindow.FreezePanes = True

Note that you have to be very specific and careful when you are using
"Active..." as it may go haywire at some point of your program. I would
advise you to avoid using it unless you have no other choices.

:

TBS - sorry it's taken so long... I took another approach. The problem is
that the Excel Application will not close! Everything else seems to be
working although it's not fully tested. If you can spot why Excel will not
close, it would be a great help.
=========
'Generic query output to Excel...
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qry As DAO.QueryDef
Dim fld As DAO.Field
Dim FldCnt As Integer
Dim PCnt As Integer
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Dim FlNm As String

Set db = CurrentDb
Set qry = db.QueryDefs(RunQry)
'get parameters...
If qry.Parameters.Count > 0 Then
For PCnt = 0 To qry.Parameters.Count - 1
Select Case qry.Parameters(PCnt).name
Case "[Forms]![frmProjectCost]![CmbCurMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurMon]").Value =
DateValue(Me.CmbCurMon.Value)
Case "[Forms]![frmProjectCost]![CmbPriMon]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriMon]").Value =
DateValue(Me.CmbPriMon.Value)
Case "[Forms]![frmProjectCost]![CmbCurPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbCurPro]").Value =
DateValue(Me.CmbCurPro.Value)
Case "[Forms]![frmProjectCost]![CmbPriPro]"

qry.Parameters("[Forms]![frmProjectCost]![CmbPriPro]").Value =
DateValue(Me.CmbPriPro.Value)
Case Else 'Unknown parameter
MsgBox "This selection is asking for" &
qry.Parameters(PCnt).name & ".", vbOKOnly, "Output Error!"

End Select
Next PCnt
Else
'No parameters in selected query
End If

Set rs = qry.OpenRecordset

'Create the spreadsheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Add
Set xlSht = xlWkb.ActiveSheet
xlWkb.SaveAs fn 'fn is a string variable that is populated with the full
path and filename the user supplied...
FlNm = xlWkb.name
xlSht.name = Left(Trim(FlNm), Len(Trim(FlNm)) - 4)

'Populate field titles and format spreadsheet...
FldCnt = 1
For Each fld In rs.Fields
With xlSht.Cells(1, FldCnt)
.Value = fld.name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.ColorIndex = 1
.Bold = True
.name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.UnderLine = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
FldCnt = FldCnt + 1
Next fld

Set xlRng = xlSht.Range("A2")
xlRng.Select
xlRng.CopyFromRecordset rs
xlSht.Columns.AutoFit
xlRng.Select
ActiveWindow.FreezePanes = True
xlSht.Range(Cells(1, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).AutoFilter
xlSht.Range(Cells(2, 1), Cells(rs.RecordCount + 1,
rs.Fields.Count)).Font.name = "Arial"
Click to expand...
Click to expand...
Click to expand...
 
Back
Top