S
sid
Please can anyone help me. I have an Access 97 database that I have
created which exports the data to Excel.
The Excel uses EXCEL9.OLB as we have Access 97 due to all our old
systems being developed with this and Excel 2000 on the same machine.
From a form in Access I have to select the parameters to run the export
which is just two drop down list fields. for Weekending and
Organisation.
Behind an button I have placed my code to export to excel.
When the button is clicked the code first looks at the weekending and
organisation field and opens a windows open save box at the exact folder
on our network drives.
The code exports to multiple unknown worksheets at run time and names
each worksheet according to its contract.
On the Form I have a logo which is copied into memory and then
pastspecial into each of the worksheets.
The problem I am having is that when the logo is pasted on to each of
the worksheets it still has its object handles selected. I am trying to
get the code to finish on each of the sheets at cell "A1"
My code is working perfectly for everything else. The logos are being
pasted on each of the sheets.
But I cant get my code to select "A1" at the end.
This is the part that sets its focus on the logo field on my form and
copies it into memory
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
And this is the part that pastes it on to each of the sheets within the
loop
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 worksheet
'*******************************************
I have tried: Set Rge = shts.Rows.Cells(1, 1)
Rge.Select
excel.Application.Range("A1").Select
But non of this works after the pastespecial
I have also tried putting the logo on by selecting the logo from a
position on the network drives
objExc.Range("G1").Select
shts.Pictures.Insert( _
"S:\Invoicing\PAYMENT CERTIFICATES\Payment Certificate
Database\Telent Logos\telent_logo.gif" _
).Select
This works but does not put the logo on to each of the worksheets and
always leaves one off.
'*********************************************
This is my full code I am sorry it is so long.
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(1) '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 'BY MAKING THE CERTIFICATE STOP AT
THE FIST SHEET WITH A SHEET THAT HAS NO DATA
SheetCount = .Worksheets.Count ' IT MAKES IT POSSIBLE TO DELETE
THIS SHEET AS THE WORKBOOK IS ONLY CREATED
FirstSheet = .Sheets(1).Name
SheetCount = .Worksheets.Count
'.Sheets(FirstSheet).Move After:=.Sheets(SheetCount)'This part
made the certificate stop at the last sheet but we want it to go to the
first sheet to delete default sheet sheet(1)
objExc.DisplayAlerts = False
.Sheets(1).delete ' As the workbook stops now at the fist sheet
this is the default sheet(1) with no data this can now be deleted
objExc.DisplayAlerts = True
.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.
*** Sent via Developersdex http://www.developersdex.com ***
created which exports the data to Excel.
The Excel uses EXCEL9.OLB as we have Access 97 due to all our old
systems being developed with this and Excel 2000 on the same machine.
From a form in Access I have to select the parameters to run the export
which is just two drop down list fields. for Weekending and
Organisation.
Behind an button I have placed my code to export to excel.
When the button is clicked the code first looks at the weekending and
organisation field and opens a windows open save box at the exact folder
on our network drives.
The code exports to multiple unknown worksheets at run time and names
each worksheet according to its contract.
On the Form I have a logo which is copied into memory and then
pastspecial into each of the worksheets.
The problem I am having is that when the logo is pasted on to each of
the worksheets it still has its object handles selected. I am trying to
get the code to finish on each of the sheets at cell "A1"
My code is working perfectly for everything else. The logos are being
pasted on each of the sheets.
But I cant get my code to select "A1" at the end.
This is the part that sets its focus on the logo field on my form and
copies it into memory
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
And this is the part that pastes it on to each of the sheets within the
loop
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 worksheet
'*******************************************
I have tried: Set Rge = shts.Rows.Cells(1, 1)
Rge.Select
excel.Application.Range("A1").Select
But non of this works after the pastespecial
I have also tried putting the logo on by selecting the logo from a
position on the network drives
objExc.Range("G1").Select
shts.Pictures.Insert( _
"S:\Invoicing\PAYMENT CERTIFICATES\Payment Certificate
Database\Telent Logos\telent_logo.gif" _
).Select
This works but does not put the logo on to each of the worksheets and
always leaves one off.
'*********************************************
This is my full code I am sorry it is so long.
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(1) '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 'BY MAKING THE CERTIFICATE STOP AT
THE FIST SHEET WITH A SHEET THAT HAS NO DATA
SheetCount = .Worksheets.Count ' IT MAKES IT POSSIBLE TO DELETE
THIS SHEET AS THE WORKBOOK IS ONLY CREATED
FirstSheet = .Sheets(1).Name
SheetCount = .Worksheets.Count
'.Sheets(FirstSheet).Move After:=.Sheets(SheetCount)'This part
made the certificate stop at the last sheet but we want it to go to the
first sheet to delete default sheet sheet(1)
objExc.DisplayAlerts = False
.Sheets(1).delete ' As the workbook stops now at the fist sheet
this is the default sheet(1) with no data this can now be deleted
objExc.DisplayAlerts = True
.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.
*** Sent via Developersdex http://www.developersdex.com ***