Results 1 to 5 of 5
  1. #1
    kirky is offline Advanced Beginner
    Windows 7 32bit Access 2010 32bit
    Join Date
    Jul 2013
    Posts
    43

    Post VBA Export access query to an excel workbook in multiple sheets

    Sir andy49,




    I have a problem of exporting access query to excel workbook in multiple sheets.
    Click image for larger version. 

Name:	Record1.JPG 
Views:	34 
Size:	179.9 KB 
ID:	26954

    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

  2. #2
    ranman256's Avatar
    ranman256 is online now VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    9,521
    use vCaption to name the tab

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, vQry, vFile, True, vCaption

  3. #3
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    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.
    It is not clear what you want to do.

    Not a clear explanation, no examples, query name (with SQL), what worksheet, .......

  4. #4
    kirky is offline Advanced Beginner
    Windows 7 32bit Access 2010 32bit
    Join Date
    Jul 2013
    Posts
    43
    sorry for late reply ssanfu, i was so busy with my work....i will give details as soon as i am available.

    Thank you

  5. #5
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    No problems.... I have been ties up also....

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 3
    Last Post: 04-18-2015, 05:24 PM
  2. Replies: 2
    Last Post: 10-15-2014, 12:30 PM
  3. Replies: 2
    Last Post: 05-16-2013, 07:43 PM
  4. Replies: 12
    Last Post: 12-17-2012, 12:47 PM
  5. Replies: 2
    Last Post: 08-14-2012, 04:24 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums