Exporting Access to Excel on Multiple Named extra sheets created

[sid]

Please can anyone help me I have an Access 97 Database with Excel 2000
using the Excel 9.0 object library.

My code is run by opening a form in access where parameters can be
selected for producing the payment certificate.

The first criteria is Organisation Id. My code checks this organisation
Id with an IF statement and then opens the windows open save window at
the correct directory to save the file which has been defined in the if
statements.

I then have a recordset Rst_2 which loops through to set the names of
the worksheets

On the Access form I have a Picture field called logo which the code
moves the focus to and copies into memory

Rst_1 contains the main data which is looped through to go on to each
worksheet.

I have various formating etc and the Logo is PasteSpecial on to cell
(1,7) on each sheet.

The problem I am having is that extra sheets without names eg sheet(1),
sheet(3) are produced and these have to be deleted afterwards. My code
other than this problem works perfectly.

Would anyone know what I have done wrong to generate the basic sheet
names when all the other sheets have the correct Rst_2 names.

I have to run 20 different payment certificates each week. I was hoping
to find a way that I would not have to keep deleting the extra sheets.

Here is my Code below:
********************************************
Private Sub ExportMultipleworksheets_Click()
Dim objExc As Excel.Application
Dim shts As Excel.Worksheet
Dim wkbk As Excel.Workbook
Dim Rge As Excel.Range
Dim Fld As Variant

Dim db As DAO.Database
Dim Rst_1 As DAO.Recordset
Dim Rst_2 As DAO.Recordset
Dim SQL_1 As String, SQL_2 As String
Dim strPath As String, FldName As String
Dim varRows As Variant
Dim strFileName As String
Dim Dir As String

If Me.cmbOrganisation = 17 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Arkenstone"
If Me.cmbOrganisation = 41 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\BML"
If Me.cmbOrganisation = 27 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\C & S Svces Ltd"
If Me.cmbOrganisation = 10 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\CH2M Hill"
If Me.cmbOrganisation = 15 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Data Techniques"
If Me.cmbOrganisation = 28 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\DCL"
If Me.cmbOrganisation = 19 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\John Henry"
If Me.cmbOrganisation = 11 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\LFR"
If Me.cmbOrganisation = 40 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Linbrooke"
If Me.cmbOrganisation = 2 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Lowery"
If Me.cmbOrganisation = 18 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\LynkLine"
If Me.cmbOrganisation = 37 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Moco"
If Me.cmbOrganisation = 5 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Nmc"
If Me.cmbOrganisation = 8 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Noviacom"
If Me.cmbOrganisation = 30 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Quay Chambers"
If Me.cmbOrganisation = 9 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\TK Cable"
If Me.cmbOrganisation = 43 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\CTC Telecomms"
If Me.cmbOrganisation = 44 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Duke Newcom"
If Me.cmbOrganisation = 45 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\DJ Jointing"
If Me.cmbOrganisation = 50 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\TE Beach"
If Me.cmbOrganisation = 52 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\ISO"
If Me.cmbOrganisation = 51 Then Dir = "s:\invoicing\PAYMENT
CERTIFICATES\Cobra Construction"


Dim i As Integer, SheetCount As Integer
Dim FileName As String, FirstSheet As String

On Error GoTo Err_Handler

Set db = CurrentDb()
'"SELECT Table1.Address FROM Table1 GROUP BY Table1.Address"
SQL_2 = "SELECT PaymentCertificatetmp.ContractName FROM
PaymentCertificatetmp GROUP BY PaymentCertificatetmp.ContractName ORDER
BY PaymentCertificatetmp.ContractName DESC;" 'select the grouped
contracts
Set Rst_2 = db.OpenRecordset(SQL_2)

Dim strFilter As String
SetStatus "Getting Data for Export ......Please Wait ....."
'this sets the windows open save filters to be excel
strFilter = ahtAddFilterItem("Excel Files (*.xls)", "*.xls")
'This calls the windows open save window
strsavefilename = ahtCommonFileOpenSave( _
OpenFile:=False, _
InitialDir:="" & Dir, _
Filter:=strFilter)


' Filter:=strFilter, _
' Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)

SetStatus "Transferring Data to Spreadsheet ..... Please
Wait ....."


Me.logo.SetFocus 'this just goes to the logo field so that it can be
copied
DoCmd.RunCommand acCmdCopy 'this copies the logo into memory
Me.cmbOrganisation.SetFocus



FileName = strsavefilename
strPath = strsavefilename


'This calls progress meter from a form.
'DoCmd.OpenForm "frmLinkToDatabasesExport"


Set objExc = New Excel.Application

If Len(FileName & "") > 0 Then 'Only run the file if the input
box has a name of the file
Set wkbk = objExc.Workbooks.add 'create a new workbook
objExc.ActiveWindow.Zoom = 95



Do Until Rst_2.EOF
FldName = Rst_2.Fields("ContractName")
Set shts = wkbk.ActiveSheet
wkbk.Sheets.add
shts.PageSetup.Orientation = xlLandscape
shts.PageSetup.Zoom = 97
' Add a new sheet to copy new data to
SQL_1 = "SELECT ContractName as Contract,OrderNumber as [Order
No],DepotName,EstimateNo,ExchArea,RateCode as NIMS,Description,Planned +
DFE as Qty,Rate,Qty*Rate as Total,PONumber FROM PaymentCertassociated
WHERE ContractName = '" & FldName & "'" & _
"ORDER BY
PaymentCertassociated.ContractName,PaymentCertassociated.OrderNumber"
Set Rst_1 = db.OpenRecordset(SQL_1)

i = 1
With Rst_1
For Each Fld In .Fields 'place the field names in
the excel A1 row.
With shts '!!!!put all the custom changes here to go on
all sheets!!!!!
.Cells(1, 6).RowHeight = 62 ' this sets the row
height for the logo that will be pasted last as this area will paste the
logo as many times as their are contracts otherwise
.Cells(2, 1).Value = "Payment Certificate: " &
Format(Me!counter, "0000")
.Cells(2, 8).Value = "Week Ending: " &
Me.cmbWeekEnding.Column(1)
.Cells(3, 1).Value = "Subcontractor: " &
Me.cmbOrganisation.Column(1)
.Cells(3, 8).Value = "Purchase Order: " &
Rst_1("PONumber")


.Cells(4, i) = Fld.Name 'this sets the row to put
the column names eg(2,1) is row 2 column 1
i = i + 1
objExc.ActiveWindow.Zoom = 95
End With
Next
End With

'this sets the column fonts
to bold eg(4,1) = row 4 column 1
Set Rge = shts.Rows("4:1") 'set the range to the
fiRst_1 row in order to adjust the font and alignment
Rge.Font.Bold = True ' Make the row bold
Rge.HorizontalAlignment = xlCenter ' align to the center


Set Rge = shts.Cells(5, 1) 'say where to start copying the
data. eg (3,1) = row 3 column 1
Rge.Font.Name = Ariel 'this sets the font name of the
main data
Rge.Font.Size = 8
Rge.CopyFromRecordset Rst_1 ' Copy the Rst_1 into the
worksheet
Rst_1.Close ' close the recordset before
calling it gain.
Set Rst_1 = Nothing

shts.Columns("A").ColumnWidth = 9.5
shts.Columns("B").ColumnWidth = 12
shts.Columns("C").ColumnWidth = 11
shts.Columns("D").ColumnWidth = 12
shts.Columns("E").ColumnWidth = 16
shts.Columns("F").ColumnWidth = 4.83
shts.Columns("G").ColumnWidth = 62.67
shts.Columns("H").ColumnWidth = 11
shts.Columns("I").ColumnWidth = 11
shts.Columns("J").ColumnWidth = 11
shts.Columns.HorizontalAlignment = xlCenter ' Align all the main
data to center in each column
'shts.Columns.AutoFit ' make the columns autofit to
fit the data

Set Rge = shts.Rows.Cells(1, 7)
Rge.PasteSpecial 'this pastes the logo on after all other data
so that it only pastes once into each workshee

Set Rge = shts.Columns("I:J")
Rge.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" ' This formats
the total colum to currency with negative values.

Set Rge = shts.Columns("K") 'This Deletes the PO Number that have
to be included in the sheet creation but are not wanted
Rge.delete

'THIS WORKS OUT THE BOTTOM OF OF THE COLUMN J4 GOES TO THE NEXT EMPTY
ROW BELOW AND PUTS THE TOTAL IN BOLD
Set Rge = shts.Range("I4").End(xlDown)
shts.Range("I4").End(xlDown).Offset(1, 0).Font.Bold = True
shts.Range("I4").End(xlDown).Offset(1, 0).Value = "Total"
shts.Range("J4").End(xlDown).Offset(1, 0).Font.Bold = True
shts.Range("J4").End(xlDown).Offset(1, 0).FormulaR1C1 =
"=sum(R4C:R[-1]C)"


Set Rge = shts.Rows("2:1") 'Format the second row fonts and
alignment left placed after all other alignment to center has been done
or the other column alingments will overwrite these settings
Rge.Font.Name = Ariel
Rge.Font.Size = 12
Rge.HorizontalAlignment = xlLeft

Set Rge = shts.Rows("3:1") 'format the third row fonts and
alignment
Rge.Font.Name = Ariel
Rge.Font.Size = 12
Rge.HorizontalAlignment = xlLeft


shts.Name = FldName 'Name each of the worksheet tabs
with the contract name


Rst_2.MoveNext

Loop
With wkbk
FirstSheet = .Sheets(1).Name
SheetCount = .Worksheets.Count
.Sheets(FirstSheet).Move After:=.Sheets(SheetCount)
.Sheets(1).Select
End With
wkbk.Close True, strPath 'Save the worksheets
objExc.Quit 'Exit Excel

End If



Exit_Handler:
'clean up
objExc.Quit
Set objExc = Nothing
Set wkbk = Nothing
Set Rge = Nothing
db.Close
Set db = Nothing
'Exit Function

Err_Handler:
Select Case err.Number
Case 1004 ' do nothing if the user does
not decide to replace the file
Resume Exit_Handler
Case Else
' MsgBox err.Number & " " & err.Description
End Select

End Sub
****************************************
Thank you,
regards,
Sid

*** Sent via Developersdex http://www.developersdex.com ***

 

[merjet]

<<The problem I am having is that extra sheets without names eg
sheet(1),
sheet(3) are produced and these have to be deleted afterwards. My code
other than this problem works perfectly.

Would anyone know what I have done wrong to generate the basic sheet
names when all the other sheets have the correct Rst_2 names.>>

I doubt you are doing anything wrong. When a user opens a new
workbook, it has a number of empty worksheets. The default is 3. This
can be changed, but there must be at least one.

You say you delete them afterwards. If you mean manually, you can do
it with code. For example: wkbk.Sheet1.Delete
To avoid any warnings, precede it with:
Application.DisplayAlerts = False

Hth,
Merjet