Exporting Logo from Access 97 to Excel 2000 by copy and pastespecial is stopping Cell A1 selection

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.
 
T

tissot.emmanuel

Hi,

May be:

objExc.Goto Range("A1"), True

Regards,

Manu/

sid said:
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.
Click to expand...
 
S

sid

Thank you Manu for your help. Your code was exactly what I was trying to
find. I have tried it but it only works without the logo.

I have tried this code to put the log on differently as I am copying the
logo from the form in access and pastespecial into each of the looped
worksheets which leaves the logo selected on each of the sheets.

This code looks at a folder on our network for the logo.
It works but it does not put the last logo onto cell "G1"
it puts the last one on cell "A1" I don't know if its because it is at
the end of loop.

Do Until Rst_2.EOF
FldName = Rst_2.Fields("ContractName")
Set shts = wkbk.ActiveSheet
wkbk.Sheets.add

objExc.Range("G1").Select
shts.Pictures.Insert ( _
"S:\Invoicing\PAYMENT CERTIFICATES\Payment Certificate
Database\Telent Logos\telent_logo.gif" _
)

regards,
Sid.
 
S

sid

This is just to let you know that I have now successfully fixed my
problem.

I had the pastespecial in the wrong place. I put it at the end instead
of the begining where the sheets were created.

this is my code now. It pastes the logo on to all the created worksheets
in position (1,7) and then finishes by selecting cells (1,1)


Do Until Rst_2.EOF
FldName = Rst_2.Fields("ContractName")
Set shts = wkbk.ActiveSheet

'puting the pastspecial of the logo here makes sure it is not
selected on each sheet
'and that each sheet finishes on cell "A1"
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.Rows.Cells(1, 1)
Rge.Select


Thank you for all your help
regards,
Sid
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Exporting Access to Excel on Multiple Named extra sheets created 1
Help needed Writing formula that totals data at end of column 7
Export Multiple Queries to Multiple Worksheets 0
Loop returns only one value, does not loop & an assignment to columnhow-to problem. 26
Problem w/code to copy worksheet to new workbook 10
Copy logo from sheet1 to new sheet3-10 1
Unhide sheet, copy and rename new sheets from list, rehide sheet 8
emailing from Excel 2

Top