asked on

Need help exporting Access table into multiple Excel worksheets

I am new to Access 2010 and learning VBA at the same time. I have a final table in Access where I have merged all the data into table. I am now wanting to export to excel using the same query, but have different sorts/filters for each worksheet. Example: Worksheet 1 = All line items; Worksheet 2 = Items for manager 1; Worksheet 3 = Items for manager 2, etc...

Here is my code. Where and what do I insert to set up multiple worksheets, and then do I need to change each query statement for each worksheet?

Private Sub Command17_Click()

On Error GoTo SubError

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim SQL As String
Dim rs1 As DAO.Recordset
Dim i As Integer

'Show user work is being performed
DoCmd.Hourglass (True)

'*********************************************
' RETRIEVE DATA
'*********************************************
'SQL statement to retrieve data from database
SQL = "SELECT [LEASEEXECUTIONEXTRACT_Key ID], [Store Name], [Center Name], [LEASEEXECUTIONEXTRACT_Brand], [LEASEEXECUTIONEXTRACT_Store Type], Document, [LEASEEXECUTIONEXTRACT_Deal Maker], [Business/ Approval Date], [Legal Package Submission Date], [RE Targeted Full Execution Date], [Date of Possession], [Construction Start Date], [Open Date / Effective Date (Extensions)], [Lease Fully Executed Date], [Approved?], [LeaseAdminTrackerMergeTable_COMMENTS], [LEASEEXECUTIONEXTRACT_Status], [LEASEEXECUTIONEXTRACT_Target Approval Month], [LeaseAdminTrackerMergerandGRELRENATable_Key ID], [LeaseAdminTrackerMergerandGRELRENATable_LEGAL LEAD], [GREL RE NA Extract_COMMENTS], [LeaseAdminTrackerMergerandGRELRENATable_FULLY EXECUTED], [LeaseAdminTrackerMergerandGRELRENATable_DOCUMENTS DISTRIBUTED], [GREL OPTIONS Extract_Key ID], [GREL OPTIONS Extract_LEGAL LEAD], COMMENTS, [GREL OPTIONS Extract_FULLY EXECUTED], [GREL OPTIONS Extract_DOCUMENTS DISTRIBUTED]" & _
"FROM LeaseExecutionFinal;"

'Execute query and populate recordset
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

'If no data, don't bother opening Excel, just quit
If rs1.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If

'*********************************************
' BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet

'Early Binding
Set xlApp = Excel.Application

xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

With xlSheet
.Name = "Lease Execution"
.Cells.Font.Name = "Calibri"
.Cells.Font.Size = 11

'Set column widths
.Columns("A").ColumnWidth = 8
.Columns("B").ColumnWidth = 20
.Columns("C").ColumnWidth = 20
.Columns("D").ColumnWidth = 9
.Columns("E").ColumnWidth = 12
.Columns("F").ColumnWidth = 17
.Columns("G").ColumnWidth = 10
.Columns("H").ColumnWidth = 12
.Columns("I").ColumnWidth = 12
.Columns("J").ColumnWidth = 12
.Columns("K").ColumnWidth = 12
.Columns("L").ColumnWidth = 12.5
.Columns("M").ColumnWidth = 12
.Columns("N").ColumnWidth = 12
.Columns("O").ColumnWidth = 10
.Columns("P").ColumnWidth = 40
.Columns("Q").ColumnWidth = 17
.Columns("R").ColumnWidth = 10
.Columns("S").ColumnWidth = 8
.Columns("T").ColumnWidth = 6
.Columns("U").ColumnWidth = 30
.Columns("V").ColumnWidth = 12
.Columns("W").ColumnWidth = 12
.Columns("X").ColumnWidth = 18
.Columns("Y").ColumnWidth = 6
.Columns("Z").ColumnWidth = 30
.Columns("AA").ColumnWidth = 12
.Columns("AB").ColumnWidth = 12

'Format columns
.Columns("A").NumberFormat = "@"
.Columns("B").NumberFormat = "@"
.Columns("C").NumberFormat = "@"
.Columns("D").NumberFormat = "@"
.Columns("E").NumberFormat = "@"
.Columns("F").NumberFormat = "@"
.Columns("G").NumberFormat = "@"
.Columns("H").NumberFormat = "m/d/yyyy"
.Columns("I").NumberFormat = "m/d/yyyy"
.Columns("J").NumberFormat = "m/d/yyyy"
.Columns("K").NumberFormat = "m/d/yyyy"
.Columns("L").NumberFormat = "m/d/yyyy"
.Columns("M").NumberFormat = "m/d/yyyy"
.Columns("N").NumberFormat = "m/d/yyyy"
.Columns("O").NumberFormat = "@"
.Columns("P").NumberFormat = "@"
.Columns("Q").NumberFormat = "@"
.Columns("R").NumberFormat = "@"
.Columns("S").NumberFormat = "@"
.Columns("T").NumberFormat = "@"
.Columns("U").NumberFormat = "@"
.Columns("V").NumberFormat = "m/d/yyyy"
.Columns("W").NumberFormat = "m/d/yyyy"
.Columns("X").NumberFormat = "@"
.Columns("Y").NumberFormat = "@"
.Columns("Z").NumberFormat = "@"
.Columns("AA").NumberFormat = "m/d/yyyy"
.Columns("AB").NumberFormat = "m/d/yyyy"

'format column headings
.Range("A1:AB1").Cells.Font.Bold = True
.Range("A1:AB1").Cells.Font.Name = "Calibri"
.Range("A1:AB1").Cells.Font.Size = 12
.Range("A1:AB1").Interior.Color = RGB(217, 217, 217)

'build column headings
.Range("A1").Value = "Key ID"
.Range("B1").Value = "Store Name"
.Range("C1").Value = "Center Name"
.Range("D1").Value = "Brand"
.Range("E1").Value = "Store Type"
.Range("F1").Value = "Document"
.Range("G1").Value = "Deal Maker"
.Range("H1").Value = "Business/ Approval Date"
.Range("I1").Value = "Legal Package Submission Date"
.Range("J1").Value = "RE Targeted Full Execution Date"
.Range("K1").Value = "Date of Possession"
.Range("L1").Value = "Construction Start Date"
.Range("M1").Value = "Open Date / Effective Date (Extensions)"
.Range("N1").Value = "Lease Fully Executed Date"
.Range("O1").Value = "Approved?"
.Range("P1").Value = "Comments (LA Team)"
.Range("Q1").Value = "Status"
.Range("R1").Value = "Target Approval Month"
.Range("S1").Value = "GRELRENA Key ID"
.Range("T1").Value = "GRELRENA Legal Lead"
.Range("U1").Value = "GRELRENA Comments"
.Range("V1").Value = "GRELRENA Fully Executed"
.Range("W1").Value = "GRELRENA Documents Distributed"
.Range("X1").Value = "GRELOptions Key ID"
.Range("Y1").Value = "GRELOptions Legal Lead"
.Range("Z1").Value = "GRELOptions Comments"
.Range("AA1").Value = "GRELOptions Fully Executed"
.Range("AB1").Value = "GRELOptions Documents Distributed"

'provide initial value to row counter
i = 2
'Loop through recordset and copy data from recordset to sheet
Do While Not rs1.EOF

.Range("A" & i).Value = Nz(rs1![LEASEEXECUTIONEXTRACT_Key ID], "")
.Range("B" & i).Value = Nz(rs1![Store Name], "")
.Range("C" & i).Value = Nz(rs1![Center Name], "")
.Range("D" & i).Value = Nz(rs1!LEASEEXECUTIONEXTRACT_Brand, "")
.Range("E" & i).Value = Nz(rs1![LEASEEXECUTIONEXTRACT_Store Type], "")
.Range("F" & i).Value = Nz(rs1!Document, "")
.Range("G" & i).Value = Nz(rs1![LEASEEXECUTIONEXTRACT_Deal Maker], "")
.Range("H" & i).Value = Nz(rs1![Business/ Approval Date], "")
.Range("I" & i).Value = Nz(rs1![Legal Package Submission Date], "")
.Range("J" & i).Value = Nz(rs1![RE Targeted Full Execution Date], "")
.Range("K" & i).Value = Nz(rs1![Date of Possession], "")
.Range("L" & i).Value = Nz(rs1![Construction Start Date], "")
.Range("M" & i).Value = Nz(rs1![Open Date / Effective Date (Extensions)], "")
.Range("N" & i).Value = Nz(rs1![Lease Fully Executed Date], "")
.Range("O" & i).Value = Nz(rs1![Approved?], "")
.Range("P" & i).Value = Nz(rs1!LeaseAdminTrackerMergeTable_COMMENTS, "")
.Range("Q" & i).Value = Nz(rs1!LEASEEXECUTIONEXTRACT_Status, "")
.Range("R" & i).Value = Nz(rs1![LEASEEXECUTIONEXTRACT_Target Approval Month], "")
.Range("S" & i).Value = Nz(rs1![LeaseAdminTrackerMergerandGRELRENATable_Key ID], "")
.Range("T" & i).Value = Nz(rs1![LeaseAdminTrackerMergerandGRELRENATable_LEGAL LEAD], "")
.Range("U" & i).Value = Nz(rs1![GREL RE NA Extract_COMMENTS], "")
.Range("V" & i).Value = Nz(rs1![LeaseAdminTrackerMergerandGRELRENATable_FULLY EXECUTED], "")
.Range("W" & i).Value = Nz(rs1![LeaseAdminTrackerMergerandGRELRENATable_DOCUMENTS DISTRIBUTED], "")
.Range("X" & i).Value = Nz(rs1![GREL OPTIONS Extract_Key ID], "")
.Range("Y" & i).Value = Nz(rs1![GREL OPTIONS Extract_LEGAL LEAD], "")
.Range("Z" & i).Value = Nz(rs1!Comments, "")
.Range("AA" & i).Value = Nz(rs1![GREL OPTIONS Extract_FULLY EXECUTED], "")
.Range("AB" & i).Value = Nz(rs1![GREL OPTIONS Extract_DOCUMENTS DISTRIBUTED], "")

i = i + 1
rs1.MoveNext

Loop

'Format cells wrap text
xlApp.Range("A:AB").Select
xlApp.Cells.Select
xlApp.Cells.EntireColumn.WrapText = True

'Format cell alignment
xlApp.Range("A:AB").Select
xlApp.Cells.Select
xlApp.Cells.EntireColumn.VerticalAlignment = xlTop

'Freeze top row
xlApp.Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True

'Highlight blank Key IDs
.Range("A2:A" & i - 1).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=LEN(TRIM(A2))=0"
With Selection.FormatConditions(1).Interior
.Color = 65535
End With

End With

SubExit:
On Error Resume Next

DoCmd.Hourglass False
xlApp.Visible = True
rs1.Close
Set rs1 = Nothing

Exit Sub

SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit

End Sub

Rey Obrero (Capricorn1)

you can use copyfromrecordset.

take a look first on this similar thread,
https://www.experts-exchange.com/questions/22687254/Export-Access-Data-to-Excel-Parsed-by-a-Specific-Field.html?&anchorAnswerId=19467728#a19467728

your codes formatting can still be written in a more simple way

for the filtered records, you need to add a Where clause to your original query.
- which field will identify the items for managers?

.

Jeremy Hayden

ASKER

Thank you Rey. I am sure it can be written in a simpler way. Since I am new to coding this gives me an easier way to break out each function, and it is easier to see what it is doing this way.

I looked at the other thread, but since my setup for the excel file is written differently, I am still unsure on where and how I use the code to tell it to use multiple sheets.......and later on when do I insert code to tell what query goes to what sheet.

As you can see I will also have some formatting I want programmed into each sheet, as well.

Field G "Deal Maker" is the field that will be used to filter each subset.

Rey Obrero (Capricorn1)

what are the values in Field Deal Maker?

Jeremy Hayden

ASKER

Gio
Brenda
Claire
Heather
Natalie
Justin

ASKER CERTIFIED SOLUTION

Rey Obrero (Capricorn1)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Paul Cook-Giles

Here are two custom functions; the first ("BuildQuery") accepts a string of sql text, and creates a query from it. The second ("ExportToExcel") uses a RecordSet to hold distinct values ("Deal Makers", in this case), and then loops through them, creating a query for each DealMaker in turn, and using TransferSpreadsheet to export the query results to the file. (Exporting the query the first time through the loop creates the file, subsequent loops exporting other queries create additional tabs inside the file. The same name (the value in Deal Maker) is used for the query and for the tab.)

All your code for formatting the spreadsheet can be put in a separate function, or added to the ExportToExcel function inside the loop to format each spreadsheet as it is created.

Public Sub BuildQuery(strSQL As String, strQueryNa As String, ReturnRecords As Boolean, Optional DisplayIn As Boolean)  ', Optional ConnectionType As String
Dim ThisDb As DAO.Database, QryDef As DAO.QueryDef

10 Set ThisDb = CurrentDb
'delete query if it already exists
20 If DLookup("ID", "MSysObjects", "Name = '" & strQueryNa & "'") <> 0 Then ThisDb.QueryDefs.Delete strQueryNa
30 Set QryDef = ThisDb.CreateQueryDef(strQueryNa)
40 QryDef.sql = strSQL
        
'query's properties are set:
50 QryDef.ReturnsRecords = ReturnRecords
60 QryDef.ODBCTimeout = 0
'if DisplayIn = Yes, then open query:
70 If DisplayIn Then
80  DoCmd.SetWarnings False
90    DoCmd.OpenQuery strQueryNa
100   DoCmd.SetWarnings True
110 End If

ExitSub:
120   Exit Sub
HandleError:
130   DoCmd.SetWarnings True
140   MsgBox "PassThru Module MakePassThruQuery Error " & Err.Number & " (" & Err.Description & ");  Line " & Erl
EndSub:
    End Sub

Open in new window

Public Sub ExportToExcel()
Dim strGroupOn As String, strQueryNa As String, RecSet As DAO.Recordset

10 strFileNa = "C:\FolderName\FileName.xlsx"
20 strGroupOn = "Deal Maker"
30 strQueryNa = "YourQueryName"
40   strSQL = "Select distinct " & strGroupOn & " from " & strQueryNa
50   Set db = CurrentDb
60   Set RecSet = db.OpenRecordset(strSQL)

70       RecSet.MoveFirst
80       Do While RecSet.EOF = False                       'loops through records in RecSet
90          BuildQuery "Select * from " & strQueryNa & " where " & strGroupOn & " = '" & RecSet.Fields(strGroupOn) & "'", RecSet.Fields(strGroupOn), True, False
100         DoCmd.TransferSpreadsheet acExport, , RecSet.Fields(strGroupOn), strFileNa, True
110         RecSet.MoveNext
120      Loop
'recordset is closed and emptied:
130   RecSet.Close
140   Set RecSet = Nothing

End Sub

Open in new window