Export Access table to multiple excel workbooks with multiple tabs (sheets)

[captdkl02]

I am using Access 2010 and Excel 2010. I need to have VB script to export the access table 502 records by 38 fields into Multiple Excel workbooks each having multiple tabs. In the Access table each record has two fields: Div and Tab that will be used to name each workbook and each tab (sheet). There are 6 unique "Div"'s to name the 6 workbooks and there are several "Tab" names for each Div (workbook).

Excel workbooks would take names from the "Div" field and the tab names would come from the "Tab" field in the Access table. First need to find workbook name (Div - Field) then the look for each sheet name (Tab - Field) to create 1st Excel workbook with all the sheets (Tab) and repeat the process. I think you need to approach of read the Access table one record at a time keying on the "Div" and "Tab" fields in creating each Excel workbook with the associated multiple tabs (sheets) that are written to a common folder.



Note: These 6 workbooks with multiple tabs were originally imported into Access from one common folder on my desktop by this routine.



Option Compare Database
Option Explicit
Private Sub Command1_Click()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPath As String, strTable As String
Dim strFile As String
Dim strPAF As String
Dim strPassword As String

' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True

' Replace C:\Filename.xls with the actual path and filename
Baseline\test3\"
strPath = Me.myFileName
strFile = Dir(strPath & "*.xlsx")

' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "Table 1"

' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = "password"

blnReadOnly = True ' open EXCEL file in read-only mode

Do While Len(strFile) > 0
strPAF = strPath & strFile
' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
Set objWorkbook = objExcel.Workbooks.Open(strPAF, , , , _
strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount

' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing

' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, 10, strTable, strPAF, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount

' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPAF

strFile = Dir()
' Delete the collection
Set colWorksheets = Nothing
Loop


' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPAF
End Sub


Any help would be greatly appreciated.



Thank you.

[captdkl02]

I used Ken Snell code sample and modified and have run time error 3012 Object "zExportQuery" already exists. I highlighted line of code where the problem exists per debugger. Does not make since it was declared as Const.

See VBA code below:
Private Sub Command17_Click()
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstMgr As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
' Replace PutEXCELFileNameHereWithoutdotxls with actual EXCEL
' filename without the .xls extension
' (for example, MyEXCELFileName, BUT NOT MyEXCELFileName.xlsx)
Const strFileName As String = "Export Access to Excel"
Const strQName As String = "zExportQuery"
Set dbs = CurrentDb
' Create temporary query that will be used for exporting data;
' we give it a dummy SQL statement initially (this name will
' be changed by the code to conform to each manager's identification)
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL) ' run time errror is here per debugger
qdf.Close
strTemp = strQName
' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID and EmployeesTable need to
' *** be changed to your table and field names
' Get list of ManagerID values -- note: replace my generic table and field names
' with the real names of the EmployeesTable table and the ManagerID field
strSQL = "SELECT DISTINCT Tab FROM Table by Div type;"
Set rstMgr = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)
' Now loop through list of ManagerID values and create a query for each ManagerID
' so that the data can be exported -- the code assumes that the actual names
' of the managers are in a lookup table -- again, replace generic names with
' real names of tables and fields
If rstMgr.EOF = False And rstMgr.BOF = False Then
rstMgr.MoveFirst
Do While rstMgr.EOF = False
' *** code to set strMgr needs to be changed to conform to your
' *** database design -- ManagerNameField, ManagersTable, and
' *** ManagerID need to be changed to your table and field names
' *** be changed to your table and field names
strMgr = DLookup("Tab", "Table by Div type", _
"Tab = " & rstMgr!Tab.Value)
' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID, EmployeesTable need to
' *** be changed to your table and field names
strSQL = "SELECT * FROM Table by Div type WHERE " & _
"Tab = " & rstMgr!Tab.Value & ";"
Set qdf = dbs.QueryDefs(strTemp)
qdf.Name = "q_" & strMgr
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing
' Replace C:\FolderName\ with actual path
DoCmd.TransferSpreadsheet acExport, 10, _
strTemp, "C:\Users\david.lehman\Documents\DSS\Budget Justification Project\Spend Plan Baseline\test\" & strFileName & ".xlsx"
rstMgr.MoveNext
Loop
End If
rstMgr.Close
Set rstMgr = Nothing
dbs.QueryDefs.Delete strTemp
dbs.Close
Set dbs = Nothing

End Sub

Any assistance is greatly appreciated.

Thank you.

David

[June7]

The error says query already exists, as in it is a saved Access query object. Check the navigation pane. Is there a query by that name?

[captdkl02]

There is one on the navigation panel, but I do not know how it was generated and saved there. I will delete it and run again.

[June7]

It is created by that line of code. Need to either first delete the query (if it exists) or leave it and just modify its SQL.

Checking for existence of query and then deleting if found can be handled by code.

[captdkl02]

June,

I have my code running now, but need to something with deleting the queries generated by the VBA. Any suggestions?

Thank you.

David

[June7]

Google: Access VBA delete querydef

Here is one http://www.access-programmers.co.uk/...d.php?t=156886

[captdkl02]

June,

I had the code working for reading one workbook with multiple tabs(sheets). I several workbooks so I added a second loop and now I stuck on with a runtime error 3061 (too few parameters. Expected 1) . It is bombing on prior starting inner loop as highlighted in red.

I believe the line ahead the syntax is not right is causing the problem.

I bet you find the problem quickly.

Thank you.

David

Private Sub Command17_Click()
Dim qdf As DAO.QueryDef, qdf2 As DAO.QueryDef
Dim dbs As DAO.Database, dbs2 As DAO.Database
Dim rstMgr1 As DAO.Recordset, rstMgr2 As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
Dim strSQL2 As String, strTemp2 As String, strMgr2 As String, strTemp3 As String
Dim strPath As String, strFileName As String

Const strQName As String = "zExportQuery"
Const strQName2 As String = "zExportQuery2"
' Passing in file path to write the exported Excel workbooks
strPath = Me.My_Export_file_path
strFileName = Me.ExcelWorkbook
Set dbs = CurrentDb
Set dbs2 = CurrentDb
' Create temporary query that will be used for exporting data;
' we give it a dummy SQL statement initially (this name will
' be changed by the code to conform to each manager's identification)
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL)
qdf.Close
strTemp = strQName
' Setting up the outer loop
strTemp2 = dbs2.TableDefs(0).Name
strSQL2 = "SELECT DISTINCT Div FROM [" & strTemp2 & "];"
Set qdf2 = dbs2.CreateQueryDef(strQName2, strSQL2)
qdf2.Close
strTemp2 = strQName2
Set rstMgr2 = dbs2.OpenRecordset(strSQL2, dbOpenDynaset, dbReadOnly)
If rstMgr2.EOF = False And rstMgr2.BOF = False Then
rstMgr2.MoveFirst
Do While rstMgr2.EOF = False

strMgr2 = DLookup("[Div]", "[" & strTemp2 & "]", _
"[Div] = '" & rstMgr2!Div.Value & "'")
strTemp3 = dbs2.TableDefs(0).Name
strSQL2 = "SELECT * FROM [" & strTemp3 & "] type WHERE " & _
"Div = " & rstMgr2!Div.Value & ";"
Set qdf2 = dbs2.QueryDefs(strTemp2)
qdf2.Name = "q_" & strMgr2
strTemp2 = qdf2.Name
qdf2.SQL = strSQL2
qdf2.Close
Set qdf2 = Nothing

' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID and EmployeesTable need to
' *** be changed to your table and field names
' Get list of ManagerID values -- note: replace my generic table and field names
' with the real names of the EmployeesTable table and the ManagerID field
' Inter loop
strSQL = "SELECT DISTINCT [" & strTemp2 & "].[Tab] FROM [" & strTemp2 & "];"
Set rstMgr1 = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)
' Now loop through list of ManagerID values and create a query for each ManagerID
' so that the data can be exported -- the code assumes that the actual names
' of the managers are in a lookup table -- again, replace generic names with
' real names of tables and fields
If rstMgr1.EOF = False And rstMgr1.BOF = False Then
rstMgr1.MoveFirst
Do While rstMgr1.EOF = False
' *** code to set strMgr needs to be changed to conform to your
' *** database design -- ManagerNameField, ManagersTable, and
' *** ManagerID need to be changed to your table and field names
' *** be changed to your table and field names
strMgr = DLookup("[Tab]", "[& strTemp2 &]", _
"[Tab] = '" & rstMgr1!Tab.Value & "'")
' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID, EmployeesTable need to
' *** be changed to your table and field names
strSQL = "SELECT * FROM [& strTemp2 &] type WHERE " & _
"Tab = " & rstMgr1!Tab.Value & ";"
Set qdf = dbs.QueryDefs(strTemp)
qdf.Name = "q_" & strMgr
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing
' Passing to transferspreadsheet command strPath, strFileName
DoCmd.TransferSpreadsheet acExport, 10, _
strTemp, strPath & strTemp2 & ".xlsx"
rstMgr1.MoveNext
Loop ' Inter loop
End If ' If then preceeding inter loop
Loop ' Outer loop
End If 'If then proceeding outer loop
rstMgr1.Close
Set rstMgr1 = Nothing
rstMgr2.Close
Set rstMgr2 = Nothing
dbs.QueryDefs.Delete strTemp
dbs2.QueryDefs.Delete strTemp2
dbs.Close
dbs2.Close
Set dbs = Nothing
Set dbs2 = Nothing

End Sub

[June7]

Nope, don't know why error. That much code is hard to follow without indentation. Use indentation in the VBA editor then post between code tags to retain indentation.

Is the recordset getting closed when it should? Have you step debugged? Link at bottom of my post has guidelines for debugging techniques.

[captdkl02]

June,

I cleaned up the code for you. I have been using debugger and kept changing the line ahead of problem, but stumped for a few hours now.

Private Sub Command17_Click()
Dim qdf As DAO.QueryDef, qdf2 As DAO.QueryDef
Dim dbs As DAO.Database, dbs2 As DAO.Database
Dim rstMgr1 As DAO.Recordset, rstMgr2 As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
Dim strSQL2 As String, strTemp2 As String, strMgr2 As String, strTemp3 As String
Dim strPath As String, strFileName As String

Const strQName As String = "zExportQuery"
Const strQName2 As String = "zExportQuery2"

' Passing in file path to write the exported Excel workbooks
strPath = Me.My_Export_file_path
strFileName = Me.ExcelWorkbook
Set dbs = CurrentDb
Set dbs2 = CurrentDb

' Create temporary query that will be used for exporting data;
' we give it a dummy SQL statement initially (this name will
' be changed by the code to conform to each manager's identification)
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL)
qdf.Close
strTemp = strQName


' Setting up the outer loop
strTemp2 = dbs2.TableDefs(0).Name
strSQL2 = "SELECT DISTINCT Div FROM [" & strTemp2 & "];"
Set qdf2 = dbs2.CreateQueryDef(strQName2, strSQL2)
qdf2.Close
strTemp2 = strQName2
Set rstMgr2 = dbs2.OpenRecordset(strSQL2, dbOpenDynaset, dbReadOnly)
If rstMgr2.EOF = False And rstMgr2.BOF = False Then
rstMgr2.MoveFirst
Do While rstMgr2.EOF = False

strMgr2 = DLookup("[Div]", "[" & strTemp2 & "]", _
"[Div] = '" & rstMgr2!Div.Value & "'")
strTemp3 = dbs2.TableDefs(0).Name
strSQL2 = "SELECT * FROM [" & strTemp3 & "] type WHERE " & _
"Div = " & rstMgr2!Div.Value & ";"
Set qdf2 = dbs2.QueryDefs(strTemp2)
qdf2.Name = "q_" & strMgr2
strTemp2 = qdf2.Name
qdf2.SQL = strSQL2
qdf2.Close
Set qdf2 = Nothing

' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID and EmployeesTable need to
' *** be changed to your table and field names
' Get list of ManagerID values -- note: replace my generic table and field names
' with the real names of the EmployeesTable table and the ManagerID field


' Inter loop
' strSQL = "SELECT DISTINCT '[" & strTemp2 & "]'.[Tab] FROM '[" & strTemp2 & "]';" ' -- I was trying to fix the syntax so it would work, but receiving runtime error 3061
strSQL = "SELECT DISTINCT [q_CDSE].[Tab] FROM [q_CDSE];" '-- I hard coded what should be passed. q_CDSE is a query
Set rstMgr1 = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly) ' -- Line where runtime error

' Now loop through list of ManagerID values and create a query for each ManagerID
' so that the data can be exported -- the code assumes that the actual names
' of the managers are in a lookup table -- again, replace generic names with
' real names of tables and fields

If rstMgr1.EOF = False And rstMgr1.BOF = False Then
rstMgr1.MoveFirst

Do While rstMgr1.EOF = False

' *** code to set strMgr needs to be changed to conform to your
' *** database design -- ManagerNameField, ManagersTable, and
' *** ManagerID need to be changed to your table and field names
' *** be changed to your table and field names

strMgr = DLookup("[Tab]", "[& strTemp2 &]", _
"[Tab] = '" & rstMgr1!Tab.Value & "'")

' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID, EmployeesTable need to
' *** be changed to your table and field names

strSQL = "SELECT * FROM [& strTemp2 &] type WHERE " & _
"Tab = " & rstMgr1!Tab.Value & ";"
Set qdf = dbs.QueryDefs(strTemp)
qdf.Name = "q_" & strMgr
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing

' Passing to transferspreadsheet command strPath, strFileName
DoCmd.TransferSpreadsheet acExport, 10, _
strTemp, strPath & strTemp2 & ".xlsx"

rstMgr1.MoveNext
Loop ' Inter loop

End If ' If then preceeding inter loop

Loop ' Outer loop

End If 'If then proceeding outer loop

rstMgr1.Close
Set rstMgr1 = Nothing

rstMgr2.Close
Set rstMgr2 = Nothing

dbs.QueryDefs.Delete strTemp
dbs2.QueryDefs.Delete strTemp2

dbs.Close
dbs2.Close

Set dbs = Nothing
Set dbs2 = Nothing

End Sub

[June7]

That's still too hard for me to wade through. As I said, use code tags to preserve indentation of nested structures.

If you want to provide files for analysis, follow instructions at bottom of my post. I might have time this weekend to get into this.

[captdkl02]

Here is VBA script to Export Access table to multiple Excel workbooks with multiple tabs. I took Ken Snell's code sample that was for a single workbook with multiple tabs and modified to include two loops as shown below:

Private Sub Command17_Click()
Dim qdf As DAO.QueryDef, qdf2 As DAO.QueryDef
Dim dbs As DAO.Database, dbs2 As DAO.Database
Dim rstMgr1 As DAO.Recordset, rstMgr2 As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
Dim strSQL2 As String, strTemp2 As String, strMgr2 As String, strTemp3 As String
Dim strPath As String, strDBTableName As String

Const strQName As String = "zExportQuery" ' Temporary query name for inter loop going each tab in the workbook
Const strQName2 As String = "zExportQuery2" ' Temporary query name for outer loop going stepping up for each workbook - WB1, WB2, WB3, WB4, WB5, & WB6

' Passing in file path to write the exported Excel workbooks
strPath = Me.My_Export_file_path

' Passing in DB Table Name that contains the Excel workbook information
strDBTableName = Me.My_DBTableName

Set dbs = CurrentDb ' Setting current database for inter loop
Set dbs2 = CurrentDb ' Setting current database for outer loop

' Create temporary query that will be used for exporting data;
' we give it a dummy SQL statement initially (this name will
' be changed by the code to conform to each workbook tab identification between "Tab" and "Div" fields

' strTemp = dbs.TableDefs(0).Name
strTemp = strDBTableName ' assigning Database table name that was passed by user
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL)
qdf.Close
strTemp = strQName

' Setting up the outer loop

' strTemp2 = dbs2.TableDefs(0).Name do not need since passing table name

strTemp2 = strDBTableName ' assigning Database table name that was passed by user
strSQL2 = "SELECT DISTINCT Div FROM [" & strTemp2 & "];"
Set qdf2 = dbs2.CreateQueryDef(strQName2, strSQL2)
qdf2.Close
strTemp2 = strQName2

Set rstMgr2 = dbs2.OpenRecordset(strSQL2, dbOpenDynaset, dbReadOnly)
If rstMgr2.EOF = False And rstMgr2.BOF = False Then
rstMgr2.MoveFirst
Do While rstMgr2.EOF = False
' strTemp3 = dbs2.TableDefs(0).Name
strTemp3 = strDBTableName ' assigning Database table name that was passed by user
strMgr2 = DLookup("[Div]", "[" & strTemp3 & "]", _
"[Div] = '" & rstMgr2!Div.Value & "'")

strSQL2 = "SELECT * FROM [" & strTemp3 & "] WHERE " & _
"Div Like """ & strMgr2 & """;"
' "Div = " & rstMgr2!Div.Value & "
Set qdf2 = dbs2.QueryDefs(strTemp2)
qdf2.Name = "q_" & strMgr2
strTemp2 = qdf2.Name
qdf2.SQL = strSQL2
qdf2.Close
Set qdf2 = Nothing

' Inter loop
strSQL = "SELECT DISTINCT Tab FROM [" & strTemp2 & "];"
Set rstMgr1 = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

' Now loop through list "Tab" values and create a query for each "Tab" field value
' so that the data can be exported
If rstMgr1.EOF = False And rstMgr1.BOF = False Then
rstMgr1.MoveFirst
Do While rstMgr1.EOF = False

' *** code to set strMgr needs to be changed to conform to your
' *** database design -- "Tab" field in the Excel workbook is key
' ***
strMgr = DLookup("[Tab]", "[" & strTemp2 & "]", _
"[Tab] = '" & rstMgr1!Tab.Value & "'")

' *** code to set strSQL needs to be changed to conform to your
' *** database design -- "Tab" field in the Excel workbook is key
' ***
strSQL = "SELECT * FROM [" & strTemp2 & "] type WHERE " & _
"Tab = """ & rstMgr1!Tab.Value & """;"
Set qdf = dbs.QueryDefs(strTemp)
qdf.Name = "q_" & strMgr
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing

' Passing to transferspreadsheet command strPath, filename is by strMgr2, and strTemp is the Excel sheet being written
DoCmd.TransferSpreadsheet acExport, 10, _
strTemp, strPath & strMgr2 & ".xlsx"
rstMgr1.MoveNext
Loop ' Inter loop

End If ' If then preceeding inter loop
rstMgr2.MoveNext ' Increment Division field from CDSE, CI, CIO, HQ, IO, IP

Loop ' Outer loop
End If 'If then proceeding outer loop

rstMgr1.Close
Set rstMgr1 = Nothing
dbs.QueryDefs.Delete strTemp
dbs.Close
Set dbs = Nothing

rstMgr2.Close
Set rstMgr2 = Nothing
dbs2.QueryDefs.Delete strTemp2
dbs2.Close
Set dbs2 = Nothing

End Sub

[June7]

So your issue is solved?