sheet that was exported Ms Access Gurus
Home Code

Automation > Excel > Export Query Groups

Export records from a Query, by whatever grouping you want, to Excel on different sheets in same file, or different files.

Quick Jump

Example Code Logic Parameters Notes Backstory Reference Share

Example

Here is an example of what your output might look like. You can use any query! And group by whatever you want. This data is separated by customer name and has an optional boxed heading at the top of the sheet.

spreadsheet with formatted data that Access created

Goto Top  

Code

'module name: _mod_aExcel_ExportQueryGroups
'     http://msaccessgurus.com/VBA/Code/aExcel_ExportQueryGroups.htm
'*************** Code Start *****************************************************
' Purpose  : Export Query Groups to Excel on different sheets in same file, or different files
' Author   : crystal (strive4peace)
' Return   : Long
' Code List: www.MsAccessGurus.com/code.htm
' LICENSE
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'
'  ALSO NEEDS:
'  VBA > Properties > Get and set ... read, write, show, delete
'   http://msaccessgurus.com/VBA/Code/Properties.htm
'
'  VBA > custom Function > GetDataType
'   http://msaccessgurus.com/VBA/Code/Fx_GetDataType.htm
'-------------------------------------------------------------------------------
'                              aExcel_ExportQueryGroups
'-------------------------------------------------------------------------------
' 
Sub aExcel_ExportQueryGroups( _ 
    psQueryname As String _ 
   ,psGroupField As String _ 
   ,psPath As String _ 
   ,Optional psFilename As String =  "" _ 
   ,Optional psFilePrefix As String =  "" _ 
   ,Optional psFileExtension As String =  "xlsx" _ 
   ,Optional psDateFormatCode As String =  "" _ 
   ,Optional psRow1Title As String =  "" _ 
   ,Optional pbHideA As Boolean = False _ 
   ,Optional piTitleCols As Integer = 1 _ 
   ) As Long 
   
'190806, 7 strive4peace
' Break a query into groups for exportin to Excel.
' Create different sheet tabs in the same file,
' or many files with one sheet each.

   'PARAMETERS
   '  psQueryname is a query name.
   '  psGroupField = break by values for separate sheets/files
   '     must BE a field in the query.
   '     if it is listed first, column A can be hidden.
   '  psPath = path to write Excel file
   'OPTIONAL
   '  psFilename is the filename.
   '      "" if each group will be a different file that is automatically created.
   '        or, if different sheet tabs will be created for each group in ONE file,
   '        this is a name such as "MyExcelFile.xlsx"
   '  psFilePrefix is what to write, if anything, before the value in the filename
   '     if groups are in different files (psFilename = "")
   '  psDateFormatCode is the date format code for adding it to the file name
   '     default = "" but you may specify something like "yymmdd" or "yymmdd_hhnn"
   '  psRow1Title = Literal text to print.
   '     Use [Field] to substitute group field value
   '  pbHideA. True to HIDE Column A. Default=False.
   '  piTitleCols: if >1 and psRow1Title is specified, cells will be merged and boxed
   
   'RETURN
   '  number of records in Query
   '
   'CALLS
   '  CorrectName
   '  DeleteFile

   aExcel_ExportQueryGroups = 0 
   
   ' late binding
   Dim oAppExcel As Object _ 
      ,oWb As Object _ 
      ,oWs As Object 
   'Reference to Microsoft Excel #.# Object Library
   '  for early binding
'   Dim oAppExcel As Excel.Application _
      ,oWb As Excel.Workbook _ 
      ,oWs As Excel.Worksheet 

   Dim db As DAO.Database _ 
      ,rs As DAO.Recordset _ 
      ,rsGroup As DAO.Recordset _ 
      ,qdf As DAO.QueryDef 
   
   Dim sQuerySQL As String _ 
      ,sPathFile As String _ 
      ,sFilename As String _ 
      ,sFilter As String _ 
      ,sSheetname As String _ 
      ,sRow1Title As String _ 
      ,sSQL As String _ 
      ,sMsg As String _ 
      ,sValue As String _ 
      ,nRecords As Long _ 
      ,iGroups As Integer _ 
      ,nRowHeadings As Long _ 
      ,nColTitle As Long _ 
      ,i As Integer _ 
      ,iCountFields As Integer _ 
      ,iSheet As Integer _ 
      ,iGroup As Integer _ 
      ,iDataType As Integer _ 
      ,iSheetsInNewWorkbook As Integer _ 
      ,vValue As Variant _ 
      ,bMakeFiles As Boolean 
   
   Dim asFieldname() As String 
   
   If Right(psPath,1) <>  "\" Then 
      psPath = psPath &  "\"
   End If 
   
   If psFilename =  "" Then 
      'path specified. Different workbooks will be created
      sPathFile =  ""
      bMakeFiles = True 
   Else 
      'file specified -- create worksheets in same workbook
      'future - count and break into files if too many
      sPathFile = psPath & psFilename 
      bMakeFiles = False 
   End If 
   
   Set db = CurrentDb 
      
   '--------------------- all records to write
   
   
   sSQL =  "SELECT Count(*) as NumRecords " _ 
      &  " FROM " & psQueryname _ 
      &  " WHERE Not IsNull(q." & psGroupField &  ")"
      &  ";"
      
   Set rs = db.OpenRecordset(sSQL,dbOpenSnapshot) 
    With rs 
      If .EOF Then 
         Debug.Print  "*** no records, " & Now 
         Debug.Print psQueryname 
         MsgBox  "There are no records to export that are grouped by " & psGroupField,, "No records, exiting"
         GoTo Proc_Exit 
      End If 
      nRecords = !NumRecords 
      .Close 
   End With 
  
   Set qdf = db.QueryDefs(psQueryname) 
   
   With qdf 
      sQuerySQL = .SQL 
      iCountFields = .Fields.Count 
      iDataType = .Fields(psGroupField).Type 
      
      'Array with Field Names for column headings
      ReDim asFieldname(iCountFields) 
      '-1 for zero-based
      For i = 0 To .Fields.Count - 1 
         asFieldname(i) = .Fields(i).Name 
      Next i 
   End With 
   Set qdf = Nothing 
   
   '--------------------- groups
   sSQL =  "SELECT DISTINCT " & psGroupField &  "  FROM " _ 
      & psQueryname &  " as q" _ 
      &  " WHERE Not IsNull(" & psGroupField &  ")" _ 
      &  " ORDER BY " & psGroupField 

   Set rsGroup = db.OpenRecordset(sSQL,dbOpenSnapshot) 
   
   With rsGroup 
      If .EOF Then 
         Debug.Print  "*** no groups, " & Now 
         Debug.Print psQueryname 

         MsgBox  "There are no groups to export",, "No group records"
         GoTo Proc_Exit 
      End If 
      .MoveLast 
      iGroups = .RecordCount 
      .MoveFirst 
   End With 

   'data is ready to write
   Set oAppExcel = CreateObject( "Excel.Application") 
   With oAppExcel 
      iSheetsInNewWorkbook = .SheetsInNewWorkbook 
      .Visible = True  'let user see what is happening
      .EnableEvents = False  'don't run any code

      If bMakeFiles = False Then 
         'One workbook, with #Groups sheets
         'future: split if too many
         .SheetsInNewWorkbook = iGroups 
         iSheet = 0  'this will be incremented
      Else 
         'Lots of workbooks with one sheet each
         .SheetsInNewWorkbook = 1 
      End If 
   
   End With 
   
   'Add a new Workbook
   Set oWb = oAppExcel.Workbooks.Add 
   Set oWs = oWb.Sheets(1) 

   iGroup = 0 
   sRow1Title =  ""
   '---------------------------- loop through groups
   Do While Not rsGroup.EOF 
      iGroup = iGroup + 1  'next Group record
'If iGroup >= 4 Then Stop
      With rsGroup 
         vValue = .Fields(psGroupField) 
         
         If psRow1Title <>  "" Then 
            sRow1Title = Replace(psRow1Title, "[Field]",vValue) 
         End If 
      End With  'rsGroup
      
      sMsg = iGroup &  " of " & iGroups &  " groups: " & vValue 
      Debug.Print sMsg,Now() 
      Application.SysCmd acSysCmdSetStatus,sMsg 
            
      'correct bad characters
      sValue = CorrectName(vValue) 
      
      'get file name
      If bMakeFiles = True Then 
         sFilename = psFilePrefix & sValue 
         If psDateFormatCode <>  "" Then 
            sFilename = sFilename &  "_" & Format(Now,psDateFormatCode) 
         End If 
         'add extension
         sFilename = sFilename &  "." & psFileExtension 
         'lots of files with one sheet in each
         sPathFile = psPath & sFilename 
         'make new workbook (with one sheet)
         Set oWb = oAppExcel.Workbooks.Add 
         Set oWs = oWb.Sheets(1) 
      Else 
         'set sheet to next one
         iSheet = iSheet + 1 
         Set oWs = oWb.Sheets(iSheet) 
      End If 
      
      'select sheet to filter and freeze
      oWs.Select 
      
      'sheetname max is 31 characters
      sSheetname = Left(sValue,31) 

      'delimit value, format numbers and dates
      If iDataType = 10 Then 
         'string - probably most common
         vValue =  """" _ 
            & Replace(vValue, """", """""") _ 
            &  """"
      Else 
         'not changing for now ... assuming number
         'todo: format as US if decimal character <> "."
         '-------------------- todo: write code
         '1,2,3,4 = whole.5 = cur. 6,7 = float. 8 = date.
      End If 
      
      'get information from query
      sSQL =  "SELECT q.* FROM " & psQueryname &  " as q " _ 
         &  " WHERE " & psGroupField &  " = " & vValue 
                        
      'open recordset for group
      'close previous recordset if not on first group
      If iGroup > 1 Then 
         rs.Close 
      End If 
      
      Set rs = db.OpenRecordset(sSQL,dbOpenDynaset) 
      
      '----- where to write stuff
      If sRow1Title <>  "" Then 
         If piTitleCols > 1 Then  'boxed -- skip row below
            nRowHeadings = 3 
         Else 
            nRowHeadings = 2 
         End If 
      Else 
         nRowHeadings = 1 
      End If 
      
      If pbHideA = True Then 
         nColTitle = 2 
      Else 
         nColTitle = 1 
      End If 
   
      '---------------------------------------export filtered recordset to worksheet
      With oWs 
         
         'write column headings in nRowHeadings
         'NateO's way ...
         Let .Range( "a" & nRowHeadings).Resize(1,iCountFields).Value = asFieldname 
         
         'write data: Copy Recordset one row below the column headings
         .Range( "a" & nRowHeadings + 1).CopyFromRecordset rs 
   
         'Rename Worksheet
         .Name = sSheetname 
            
         '------------------------- Format
         With .Cells.Font 
            .Name =  "Calibri"
            .Size = 10 
         End With 
         
         'xlDiagonalDown 5
         'xlDiagonalUp 6
         'xlEdgeLeft 7
         'xlEdgeTop 8
         'xlEdgeBottom 9
         'xlEdgeRight 10
         'xlInsideVertical 11
         'xlInsideHorizontal 12
         
         'column heading row
         With .Range(.Cells(nRowHeadings,1),.Cells(nRowHeadings,iCountFields)) 
            .VerticalAlignment = -4108    'xlCenter
            .Font.Size = 8  'make larger if desired
            .HorizontalAlignment = -4131  'xlLeft, xlHAlignLeft
            With .Interior 
               .Color = RGB(225,225,225)  'light gray
            End With 
            For i = 7 To 12  'outer and inner borders
               With .Borders(i) 
                  .LineStyle = 1  'xlContinuous
                  .Color = RGB(150,150,150)  'medium gray
                  .Weight = 2  'xlThin
               End With 
            Next i 
         End With 

         .Range( "C" & nRowHeadings + 1).Select 
                  
         'Hide Column A?
         If pbHideA = True Then 
            .Columns(1).EntireColumn.Hidden = True 
         End If 
         
         'set margins, orientation, header
         'do this last in With block
         With .PageSetup 
            'title rows is 1 to the row headings
            .PrintTitleRows =  "1:" & nRowHeadings 
            'title columns
            If pbHideA Then 
               .PrintTitleColumns =  "B:B"
            Else 
               .PrintTitleColumns =  "A:B"
            End If 
           'tab name, date, page, total pages
           '&[Tab] - 8/7/2019 10:43:00 AM - &[Page]/&[Pages]
           .RightHeader =  "&""Times New Roman,Italic""&10&A - " & Now() &  " - &P/&N"
           .LeftMargin = 36  'oAppExcel.InchesToPoints(0.5)
           .RightMargin = 36 
           .TopMargin = 36 
           .BottomMargin = 36 
           .HeaderMargin = 24 
           .FooterMargin = 24 
           .CenterHorizontally = True 
           .Orientation = 2  'xlLandscape
         End With 

      End With  'oWs
      
      ' turn on the auto filter
      oAppExcel.Selection.AutoFilter 
      'do best-fit after filter arrows, instead of before?
   
      With oWs 
         'best-fit columns
         '-- done after filter arrows so column heading insn't chopped
         '        but before title row is written
         .Range(.Columns(1),.Columns(iCountFields)).EntireColumn.AutoFit 
         
         'title row
         If sRow1Title <>  "" Then 
            With .Cells(1,nColTitle)  'title is in row 1
               .Value = sRow1Title 
               .Font.Size = 12    'adjust?
               .Font.Bold = True 
            End With 
            If piTitleCols > 1 Then  'box title if > 1 column
               With .Range(.Cells(1,nColTitle),.Cells(1 _ 
                  ,nColTitle + piTitleCols - 1)) 
                  .MergeCells = True 
                  For i = 7 To 10  'outer borders
                     With .Borders(i) 
                        .LineStyle = 1  'xlContinuous
                        .Color = RGB(100,100,100)  'dark gray
                        .Weight = -4138  'xlMedium
                     End With 
                  Next i 
               End With 
            End If 
         End If 
         
         'best-fit rows
         .Cells.EntireRow.AutoFit 
            
      End With  'oWs
      
      'freeze panes -- 2 columns, rows to just below heading
      'don't do things after feezing ...
      oAppExcel.ActiveWindow.FreezePanes = True 
      
      'save file and close
      If bMakeFiles = True Then 
         'close and specify PathFile to save
         If sPathFile <>  "" Then 
            'delete path\file if it already exists
            If Not DeleteFile(sPathFile) Then 
            
               sMsg =  "Can't delete " & sPathFile _ 
                  & vbCrLf & vbCrLf &  "Click OK to continue if you switched and closed while this message was open"
               If MsgBox(sMsg,vbOKCancel, "Error naming file, OK if closed now") = vbOK Then 
                  If Not DeleteFile(sPathFile) Then 
                     sMsg =  "Can't delete " & sPathFile _ 
                        & vbCrLf & vbCrLf &  "change parameters and try again"
                     
                     Debug.Print sMsg, "Aborting " & Now() 
                     MsgBox sMsg,, "Error replacing file, Aborting"
                     GoTo Proc_Exit 
                  End If 
               Else 
                  'cancel
                  GoTo Proc_Exit 
               End If 
               
            End If 
         
            oWb.Close True,sPathFile 
            sPathFile =  ""
         End If 
      Else 
         'see if iSheet too big?
      End If 
      
      ' next group
      rsGroup.MoveNext 
   Loop 
   
   'save file and close
   'this will happen if one workbook
   'and lots of sheets
   If sPathFile <>  "" Then 
      'delete file if it already exists
      Call DeleteFile(sPathFile) 
      'select first sheet
      oWb.Sheets(1).Select 
      'save file
      oWb.Close True,sPathFile 
   End If 
   
   Set oWs = Nothing 
   Set oWb = Nothing 

   aExcel_ExportQueryGroups = nRecords 

Proc_Exit: 
   On Error Resume Next 

   If Not rs Is Nothing Then 
      rs.Close 
      Set rs = Nothing 
   End If 
   
   If Not rsGroup Is Nothing Then 
      rsGroup.Close 
      Set rsGroup = Nothing 
   End If 
   If Not rs Is Nothing Then 
      rs.Close 
      Set rs = Nothing 
   End If 
   Set db = Nothing 
      
   Set oWs = Nothing 
   If Not oWb Is Nothing Then 
      oWb.Close True,sPathFile 
      Set oWb = Nothing 
   End If 
   
   If Not oAppExcel Is Nothing Then 
      With oAppExcel 
         'put SheetsInNewWorkbook back to way it was before
         .SheetsInNewWorkbook = iSheetsInNewWorkbook 
         'quit this instance of Excel (CreateObject used)
         .Quit 
      End With 
      ' release Excel.Application object variable
      Set oAppExcel = Nothing 
   End If 
   
   If aExcel_ExportQueryGroups <> 0 Then 
      sMsg =  "Exported " & nRecords &  " records in " _ 
         & iGroups &  " groups" _ 
         & vbCrLf & vbCrLf &  "created " _ 
         & IIf(bMakeFiles = True _ 
            ,iGroups &  " Files" _ 
            , "1 File with " & iGroups &  " Sheets") 
        
      Debug.Print  "---- Done " & Now() 
      Debug.Print Space(5) & sMsg 
      sMsg = sMsg & vbCrLf & vbCrLf &  "Open Path? "
      
      If MsgBox(sMsg,vbYesNo, "Done") = vbYes Then 
         Application.FollowHyperlink psPath 
      End If 
   End If 
   
   Application.SysCmd acSysCmdClearStatus 
   Exit Function 
  
Proc_Err: 
   MsgBox Err.Description _ 
      & vbCrLf & vbCrLf & sPathFile &  " may be open or file name is bad",,_ 
        "ERROR " & Err.Number _ 
        &  "   Error writing file aExcel_ExportQueryGroups"
   Resume Proc_Exit 
   Resume 
   
End Function 

  
'~~~~~~~~~~~~~~~~~~~~~~~~~~ CorrectName
Function CorrectName( _ 
   ByVal psName As String _ 
   ,Optional psReplaceCharacter As String =  "_" _ 
   ) As String 
'strive4peace

   Dim i As Integer _ 
      ,sName As String _ 
      ,sChar As String * 1 _ 
      ,sLastChar As String _ 
      ,sNewChar As String 

   'PARAMETERS
   '  psName is the string you want to correct
   'RETURNS
   '  corrected name
    
   'EXAMPLE USEAGE
   'in code to fix names before writing files
   '  or renaming application objects
   '  sNewName =  CorrectName(sName)
   'in a query:
   '  field --> CorrectName: CorrectName([Fieldname])
    
   'EXAMPLE
   ' ? CorrectName("as(,48209j@##@!")
   ' --> as_48209j_
   ' ? CorrectName("Fred Flintstone")
   ' --> Fred_Flintstone
   ' ? CorrectName("Fred Flintstone","")
   ' --> FredFlintstone
    
   CorrectName =  ""
    
   If Len(Nz(psName)) < 1 Then Exit Function 
   
   psName = LTrim(Trim(psName)) 
   
   For i = 1 To Len(psName) 
      sChar = Mid(psName,i,1) 
      
      'also replaces spaces
      If InStr( "`!@#$%^&*()+=|\:;""'<>,.?/ ",sChar) > 0 Then 
         sNewChar = psReplaceCharacter 
      Else 
         sNewChar = sChar 
      End If 
 
      If sNewChar <>  "" Then 
         If (sLastChar = psReplaceCharacter _ 
               And sNewChar = psReplaceCharacter) Then 
            'SKIP - leave the same for multiple characters to replace in a row
         Else 
            sName = sName & sNewChar 
         End If 
      End If 
 
      sLastChar = sNewChar 
   Next i 

   CorrectName = sName 
        
End Function 

Function DeleteFile(psPathFile As String) As Boolean 
'True is PathFile is okay to use
'False if it couldn't be deleted -- maybe it is open?
   On Error Resume Next 
   DeleteFile = True 
   Dim sFile As String 
   sFile =  ""
   sFile = Dir(psPathFile) 
   If sFile <>  "" Then 
      Kill psPathFile 
      DoEvents 
      'make sure file is gone
      If Dir(psPathFile) <>  "" Then 
         DeleteFile = False 
      End If 
   End If 
End Function 


'-------------------------------------------------------------------------------
'                              call_aExcel_ExportQueryGroups
'-------------------------------------------------------------------------------
' 
Sub call_aExcel_ExportQueryGroups() 
's4p
   Dim sQueryname As String _ 
      ,sGroupField As String _ 
      ,sPath As String _ 
      ,sFilename As String _ 
      ,sFilePrefix As String _ 
      ,sRow1Title As String _ 
      ,iTitleCols As Integer 
      
   sQueryname =  "qMyQueryName"   ' ------------- customize
   sGroupField =  "MyFieldname"   ' ------------- customize
   
   '-------------------------------------- customize and choose
   'if you want to make a file for each group
   ' set filename to "",
   ' and prefix to whatever you want before each group value,
   ' if anything
   sFilename =  ""
   sFilePrefix =  "CustomerOrders_"
   '  OR
   'UNCOMMENT for all sheets to be in the same workbook,
   'specify a filename yourself
   'sFilename = "CustomerOrders_all.xlsx"
   '--------------------------------------
   
   'create a title row above headings row
   '[Field] will be replaced with group value
   ' use "" if you don't want any rows above the column headings
   sRow1Title =  "[Field]" ' ------------- customize to add whatever other text you want
   'merge title across 4 columns. If =1 then no box, and headings are on row 2.
   iTitleCols = 4 
   
   sPath = CurrentProject.Path &  "\Reports\" ' ---------- customize if desired
   'if path doesn't exist, make it
   If Dir(sPath) =  "" Then  'this only works for one folder level
      MkDir sPath 
   End If 
   'export the data to Excel
      Call aExcel_ExportQueryGroups(sQueryname,sGroupField _ 
      ,sPath,sFilename,sFilePrefix,_ 
      ,,sRow1Title,True,iTitleCols) 
End Sub 
'*************** Code End *******************************************************



    Goto Top  

Logic

The beauty of this function is that it can use any Select query for outputting, and you can specify any field to group by, which will often be a string. It can even be a calculated field in your query that is a concatenation of other values. There is currently code to handle strings and numbers for grouping. Where code is needed to add processing for dates, there is a comment. If your decimal separator is not ".", there is a comment where code is needed to handle that too.

Goto Top  

Backstory

This is such a common thing to want to do ... keep track of data in Access and then shuffle it to Excel for slicing and dicing, graphing and projecting, and making files that are easy to share with others.

Goto Top  

Reference

SheetsInNewWorkbook

Docs / Office VBA Reference / Excel / Object Model / Application object / Properties / SheetsInNewWorkbook

Help: Application.SheetsInNewWorkbook property (Excel)

Goto Top  

Share

Share with others ... here's the link to copy:
http://msaccessgurus.com/VBA/Code/aExcel_ExportQueryGroups.htm

Do you have something to say?

Share your comments! Was something not clear? Did you find a bug? Is an explanation wrong or not sufficient? Do you want the code do more (there is always more)?

Some of you write to say thanks and tell me what you're doing with Access ... its nice to hear from you. I want you to be the best you can with Access, and leverage other applications like Excel, Word, and PowerPoint ... and Windows.

Are you a developer? Do you want to share? Email to ask about getting your pages added to the code index.

Let's communicate, collaborate, and appreciate ... we all get better by sharing. Email me anytime at info@msAccessGurus.com. I love hearing from you. ~ crystal

Goto Top