S
sid
Please can anyone help me. I have created an Access 97 Database that
does a large Sql query stored on a remote server and outputs to multiple
Excel Worksheets.
It also copies a logo from the access form and pastes it on each
worksheet.
The code uses two sql inputs one to get the contractnames which is the
criteria for the second sql that contains the main data. As I do not
know in advance before running the query what contracts will be
captured.
Each of the contracts is put on to a new worksheet.
The problems I am trying to solve is on each of the worksheets in Excel
I am trying to put a total of Column "J" at the bottom of column "J" the
next blank cell and format it to bold with an underline.
On each of the sheets I do not know how many rows of Data column "J"
will have in advance. I have tried xldown and ofsets but I am not having
much success.
Here is my Code.
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 rng As Excel.Range 'This is for calculating column "J "
Dim astRow As Excel.Range 'This is for calculating the last row in
column "J "
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"
'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, _
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 a save file api and works but it is not the standard windows
open save api.
'FileName = InputBox("Enter the name of the file to be saved." & Chr(13)
& Chr(13) & " The file will be saved in C:\Temp.")
'strPath = "c:\temp" & "\" & FileName & ".xls" 'same the file on the
same path of the db.
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
Do Until Rst_2.EOF
FldName = Rst_2.Fields("ContractName")
Set shts = wkbk.ActiveSheet
wkbk.Sheets.add
' 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 FROM PaymentCertificatetmp WHERE
ContractName = '" & FldName & "'" 'Fiter by each ContractName
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 log 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: "
.Cells(2, 8).Value = "Week Ending: "
.Cells(3, 1).Value = "Subcontractor: "
.Cells(3, 8).Value = "Purchase Order: "
.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 xlPasteAll '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 IS WHERE I AM HAVING TROUBLE*******
Set rng = shts.Range(Cells(4, "J"), Cells (Rows.Count,
"J").End(xlUp))
Set lastRow = rng(rng.Count).Offset(1, 0)
'TRYING TO PUT TOTAL AT END OF COLUMN JA
**************************************************
******************************************************
'rge.Formula = sum(" & rge(
'Excel.Range("J" & cnt + 11).Formula = "=sum(J4:J" & cnt + 10 &
")"
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
*** Sent via Developersdex http://www.developersdex.com ***
does a large Sql query stored on a remote server and outputs to multiple
Excel Worksheets.
It also copies a logo from the access form and pastes it on each
worksheet.
The code uses two sql inputs one to get the contractnames which is the
criteria for the second sql that contains the main data. As I do not
know in advance before running the query what contracts will be
captured.
Each of the contracts is put on to a new worksheet.
The problems I am trying to solve is on each of the worksheets in Excel
I am trying to put a total of Column "J" at the bottom of column "J" the
next blank cell and format it to bold with an underline.
On each of the sheets I do not know how many rows of Data column "J"
will have in advance. I have tried xldown and ofsets but I am not having
much success.
Here is my Code.
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 rng As Excel.Range 'This is for calculating column "J "
Dim astRow As Excel.Range 'This is for calculating the last row in
column "J "
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"
'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, _
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 a save file api and works but it is not the standard windows
open save api.
'FileName = InputBox("Enter the name of the file to be saved." & Chr(13)
& Chr(13) & " The file will be saved in C:\Temp.")
'strPath = "c:\temp" & "\" & FileName & ".xls" 'same the file on the
same path of the db.
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
Do Until Rst_2.EOF
FldName = Rst_2.Fields("ContractName")
Set shts = wkbk.ActiveSheet
wkbk.Sheets.add
' 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 FROM PaymentCertificatetmp WHERE
ContractName = '" & FldName & "'" 'Fiter by each ContractName
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 log 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: "
.Cells(2, 8).Value = "Week Ending: "
.Cells(3, 1).Value = "Subcontractor: "
.Cells(3, 8).Value = "Purchase Order: "
.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 xlPasteAll '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 IS WHERE I AM HAVING TROUBLE*******
Set rng = shts.Range(Cells(4, "J"), Cells (Rows.Count,
"J").End(xlUp))
Set lastRow = rng(rng.Count).Offset(1, 0)
'TRYING TO PUT TOTAL AT END OF COLUMN JA
**************************************************
******************************************************
'rge.Formula = sum(" & rge(
'Excel.Range("J" & cnt + 11).Formula = "=sum(J4:J" & cnt + 10 &
")"
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
*** Sent via Developersdex http://www.developersdex.com ***