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 Rge = objExc.WorksheetFunction.Sum("J65536").End(xlUp).Offset(rowOffset:=1, columnOffset:=0).Activate
'TRYING TO PUT TOTAL AT END OF COLUMN J
**************************************************
******************************************************
'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
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 Rge = objExc.WorksheetFunction.Sum("J65536").End(xlUp).Offset(rowOffset:=1, columnOffset:=0).Activate
'TRYING TO PUT TOTAL AT END OF COLUMN J
**************************************************
******************************************************
'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
