Sir andy49,
I have a problem of exporting access query to excel workbook in multiple sheets.
That is a templates of the supervisor and i dont want to change it. I want to retain as is for there were formulas and conditional he added.
What I want now is the same format of datum I made in access database and i put it in a query. I want this query to be exported to the format
given of my supervisor and export this data as well to each sheet name referring to company column.
I have a code where i got from the forum before and its almost the same with what i want but the problem is I cant change it to what I want to produce.
Could you please look at this and help me...or anybody can help me for this...I need this as a final of my database....
Thank you in advance...
Here is the code
Code:
'##########################################################################################
' Code written by: Dan Halliday (aka pootle_flump)
' Code produced on: 2006_01_05
' Summary: Example of excel automation and some of the techniques you can use to
' produce excel reports from Access\ VB.
' Specifically, a table (representing a crosstab report) is exported to
' excel and the worksheet formatted. This same data is then split amongst further worksheets.
'
' Requirements: This file is produced in Access 2003 and includes references to Excel 2003 library.
' If you are using a version of Office prior to this then change the references.
' There should also be a file called "MyTemplate.xls" to accompany this file.
' The code will work without it however please copy the file to the same directory
' as the Access file if you have it.
'
' NOTE - if you are retrieving data from a Server RDBMS then you might want to check that it
' is ok with the DBA. This code is quick but not so efficient for the BE (i.e. there are
' multiple calls to the database and all data is returned twice). This can be avoided by
' shifting a lot of the work to the client but it results in the report running more slowly.
'
' The original file is available here: http://www.dbforums.com/showthread.php?t=1605962
' Please let me know if you have any problems or comments - please either create a new
' thread or PM me. Please do not post on the thread linked above.
'
' I hope there is at least something in this file that you find helpful :-)
'
' To run: Copy and paste ExportData_Sheet_Intermed_C into the Imediate Window (CTRL + G) and press Enter.
'
' Disclaimer: All code is provided "as is" with no warranties or guarantees. You choose to run this code at
' your own risk.
'
' Credit: This is code is provided for free for your own use.
' You are free to copy and\ or alter the below code and incorporate in your own projects however
' please include the above header in any module in which you do this.
'##########################################################################################
Option Compare Database
Option Explicit
Sub ExportData_Sheet_Intermed_C(cboexport As String)
On Error GoTo ExportData_Error
'constants
' - the header row
Const HEADER_ROW As Byte = 2
Const LEFTMOST_COL As Byte = 1
' - the column to freeze on
Const COLUMN_FREEZE As Byte = 4
Const TEMPLATE_SHEET_NAME As String = "Template_Sheet"
'DAO objects to get the data - ADO works fine too - I just used DAO since JET is the data source.
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim rs_groups As DAO.Recordset
Dim fld_dum As DAO.Field
Dim fld_group As DAO.Field
'Excel objects to manipulate Excel
Dim exApp As Excel.Application
Dim exBook As Excel.Workbook
Dim exSheet As Excel.Worksheet
Dim exRange As Excel.Range
Dim exChtO As Excel.ChartObject
Dim exCht As Excel.Chart
Dim exSer As Excel.Series
'variables to use for formatting loops
Dim NoOfCols As Integer
Dim NoOfRows As Integer
'Iterant to keep track of the grouping clumn value
Dim i_group As Integer
'Iterant for misc loops
Dim i As Integer
'String to store the destination worksheet
Dim BookName As String
'Array object to be used by the subtotal
Dim TotCols() As Integer
Set db = Application.CurrentDb
'Get the distinct values of the column to group on (note we add a dummy record to account for the worksheet that will display ALL data).
Set rs_groups = db.OpenRecordset("SELECT DISTINCT 0 AS OrderCol, 'ALL Data' AS [" & cboexport & "] FROM CivilInspectionQ UNION ALL SELECT DISTINCT 1, NZ([" & cboexport & "], 'Null Value') FROM CivilInspectionQ ORDER BY 1, 2 ASC")
'Set the field objects
Set fld_dum = rs_groups.Fields(0)
Set fld_group = rs_groups.Fields(1)
'Instantiate the excel objects
Set exApp = New Excel.Application
'Get the workbook name
BookName = MId(db.Name, 1, InStrRev(db.Name, "\")) & "MyTemplate.xls"
'Check workbook template exists
If Dir(BookName) = vbNullString Then
'It doesn't... so create it
Set exBook = exApp.Workbooks.Add
Else
'It does... so open it
Set exBook = exApp.Workbooks.Open(BookName)
End If
'Change the filename so you don't overwrite your template
BookName = Replace(Replace(BookName, ".xls", "") & "_" & Year(Date) & "_" & Month(Date) & "_" & Day(Date) & "__" & Replace(Replace(Format(Time(), "medium time"), " ", "_"), ":", "-"), "MyTemplate", "QAQC_CivilInspectionRecord") & "_a"
'We don't want to save over any other reports so we tack a character to the end of the name.
'Note we make sure the loop runs once at a minimum.
Do
i = i + 1
BookName = MId(BookName, 1, Len(BookName) - 1) & Chr(96 + i)
Loop While Dir(BookName & ".xls") <> vbNullString
'Add the extension
BookName = BookName & ".xls"
'Save it
exBook.SaveAs BookName
exApp.Visible = True
'Prevent users from being able to mess with the spreadsheet whilst you are working on it - very important.
exApp.Interactive = False
'#################################################################################################
'To start we will create a template worksheet where we will perform all the formatting
'common to all the sheets (e.g. headers). We will then use this template for each new worksheet.
'This is because formatting worksheets is quite costly.
'#################################################################################################
'Get the data
Set rs = db.OpenRecordset("SELECT * FROM CivilInspectionQ ORDER BY NZ([" & cboexport & "], 'Null Value')")
'Instantiate the exSheet object to the first work sheet
Set exSheet = exBook.Worksheets(1)
exSheet.Activate
'Name the sheet
exSheet.Name = TEMPLATE_SHEET_NAME
'Populate the column variable - note we don't deduct one from the value as
'Excel arrays and cells start at 1 not 0
NoOfCols = rs.Fields.Count
'Start totcols off - this array keeps track of all the numeric fields that will need totalling.
ReDim TotCols(0)
'Loop through the recordset fields
For i = 0 To NoOfCols - 1
Set fld = rs.Fields(i)
'Write in the column headings
exSheet.Cells(HEADER_ROW, i + LEFTMOST_COL).Value = fld.Name
Next i
'Add autofilter on header row - alternative way of defining a range
exSheet.Range(exSheet.Cells(HEADER_ROW, LEFTMOST_COL), exSheet.Cells(HEADER_ROW, NoOfCols + LEFTMOST_COL)).AutoFilter
'Remove grid lines for sheet
exApp.ActiveWindow.DisplayGridlines = False
'Use our variables to format the header cells using internal vb colour constant
exSheet.Cells.Range(Chr(64 + LEFTMOST_COL) & HEADER_ROW, ExcelCodes(NoOfCols + LEFTMOST_COL - 1) & HEADER_ROW).Interior.Color = VBA.ColorConstants.vbBlue
exSheet.Cells.Range(Chr(64 + LEFTMOST_COL) & HEADER_ROW, ExcelCodes(NoOfCols + LEFTMOST_COL - 1) & HEADER_ROW).Font.Color = VBA.ColorConstants.vbWhite
'Set up print header text
exSheet.PageSetup.CenterHeader = "Inspection Monitoring"
exSheet.PageSetup.RightHeader = "Date Run - " & Format(Date, "Medium date")
'repeat for footer
exSheet.PageSetup.CenterFooter = exSheet.PageSetup.CenterHeader
exSheet.PageSetup.RightFooter = exSheet.PageSetup.RightHeader
'The report is a biggie so knock the zoom down a bit
exApp.ActiveWindow.Zoom = 80
'for the same reason set the orientation to landscape
exSheet.PageSetup.Orientation = xlLandscape
'Freeze panes
exSheet.Cells(HEADER_ROW + 1, COLUMN_FREEZE + LEFTMOST_COL - 1).Activate
exApp.ActiveWindow.FreezePanes = True
'We want the frozen panes to be repeated when printed so sort out the pagesetup
exSheet.PageSetup.PrintTitleColumns = "$" & Chr(64 + LEFTMOST_COL) & ":$" & Chr(COLUMN_FREEZE + 63 + LEFTMOST_COL - 1)
exSheet.PageSetup.PrintTitleRows = "$" & HEADER_ROW & ":$" & HEADER_ROW
'#################################################################################################
'Template now completed
'#################################################################################################
'Set i_group to 2 - this is the first worksheet *after* the Template_Sheet worksheet
i_group = 2
'We now loop through the rows in rs_groups as these indicate the worksheets we want to create & populate.
Do While Not rs_groups.EOF
'Clear the recordset if we are past the first iteration
If Not rs Is Nothing And fld_dum.Value <> 0 Then Set rs = Nothing
'If this is not the dummy record then....
If fld_dum.Value <> 0 Then
'..retrieve the subset we are interested in.
'NOTE - We can legitimatly select * here because the table is representing a crosstab and therefore the number
'and names of columns may not be known
Set rs = db.OpenRecordset("SELECT * FROM CivilInspectionQ WHERE NZ([" & cboexport & "], 'Null Value') = '" & Replace(fld_group.Value, "'", "''") & "'")
End If
'Create a copy of the template worksheet and paste it after the last worksheet.
exBook.Worksheets(1).Copy , exSheet
'Instantiate the exSheet to this new copy.
Set exSheet = exBook.Worksheets(i_group)
exSheet.Activate
'Set the name
exSheet.Name = fld_group.Value
'Populate recordset
If Not rs.EOF Then rs.MoveLast: rs.MoveFirst
'Populate the row variable - note we don't deduct one from the value as
'Excel arrays and cells start at 1 not 0
NoOfRows = rs.RecordCount
'Pop the data into Excel
exSheet.Range(Chr(64 + LEFTMOST_COL) & HEADER_ROW + 1).CopyFromRecordset rs
'And again - using both variables this time to format the data and header. Using RGB colour palette this time
exSheet.Cells.Range(Chr(64 + LEFTMOST_COL) & HEADER_ROW, ExcelCodes(NoOfCols + LEFTMOST_COL - 1) & (NoOfRows + HEADER_ROW)).Borders.Color = RGB(0, 0, 0)
'Adjust column widths
exSheet.Columns.EntireColumn.AutoFit
'We like to showboat so set the bottom most data cell as the active cell so the user
'gets to see the totals appearing
exSheet.Cells.SpecialCells(xlLastCell).Activate
'Adjust up print header text for this specific group & repeat for footer
'Note - this is relatively slow to do so you can remove it to speed up the process.
exSheet.PageSetup.CenterHeader = exSheet.PageSetup.CenterHeader & " - " & cboexport & " = '" & fld_group & "'"
exSheet.PageSetup.CenterFooter = exSheet.PageSetup.CenterHeader
'Return focus top left most data cell.
exSheet.Cells(HEADER_ROW + 1, LEFTMOST_COL).Activate
'Set up the recordset & iterant for the next pass.
rs_groups.MoveNext
i_group = i_group + 1
Loop
Set exSheet = exBook.Worksheets(1)
exSheet.Activate
'Delete the template worksheet, supressing confirmation messages.
exApp.DisplayAlerts = False
exBook.Worksheets(TEMPLATE_SHEET_NAME).Delete
exApp.DisplayAlerts = True
'We probably have a fair few sheets so change the TabRatio
exBook.Windows(1).TabRatio = 0.9
'Save it
exBook.Save
ExportData_Exit:
'We don't want an error here otherwise we loop forever
On Error Resume Next
'Very important - always account for in error trap
exApp.Interactive = True
exApp.DisplayAlerts = True
'Clean Up
Set fld_dum = Nothing
Set fld_group = Nothing
rs_groups.Close
Set rs_groups = Nothing
Set fld = Nothing
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
Set exSer = Nothing
Set exCht = Nothing
Set exChtO = Nothing
Set exRange = Nothing
Set exSheet = Nothing
Set exBook = Nothing
Set exApp = Nothing
Exit Sub
ExportData_Error:
MsgBox Err.Description
Stop
' Resume
Resume ExportData_Exit
End Sub
'Function to convert an integer value to the relevent column alpha character.
'This isn't stricly necessary (there is another way of achieving the same result) but
'this is the method I used :-)
Private Function ExcelCodes(ByVal intColNo As Integer) As String
Dim strCol As String
Do While intColNo > -1
If intColNo > 26 Then
strCol = Chr(64 + ((intColNo - 1) \ 26))
intColNo = intColNo - (26 * ((intColNo - 1) \ 26))
Else
strCol = strCol & Chr(64 + intColNo)
Exit Do
End If
Loop
ExcelCodes = strCol
End Function