Question Export access table to multiple excel workbooks with multiple tabs (1 Viewer)

captdkl02

Registered User.
Local time
Today, 17:21
Joined
Dec 4, 2012
Messages
21
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).
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 = "DSS Consolidated SP-6"
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = "gnome"
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.
 

DavidAtWork

Registered User.
Local time
Today, 21:21
Joined
Oct 25, 2011
Messages
699
A simple way to achieve this without too much VBA would be to create several queries, one for each tab in a single workbook and name them how you want each tab named, then just export each query to the same xls file and this will create a single workbook with multiple tabs
If you use:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "tabNameX", "C:\FolderName\FileName1.xls", True
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "tabNameY", "C:\FolderName\FileName1.xls", True
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "tabNameZ", "C:\FolderName\FileName1.xls", True

etc
If your VBA is quite strong there are other methods that will be more dynamic and economical
David
 

captdkl02

Registered User.
Local time
Today, 17:21
Joined
Dec 4, 2012
Messages
21
David,

I looking for a similar VBA routine that I had for importing the 6 workbooks with the multiple tabs into Access, but another exporting them back to 6 workbooks.
 

DavidAtWork

Registered User.
Local time
Today, 21:21
Joined
Oct 25, 2011
Messages
699
If you're just exporting to Excel, you can do this without any Excel objects. If I'm understanding your remit correctly, it's just a matter of querying one table and exporting the results. The criteria for each set will change, but the export process is the same so it would be suitable for a 2 nested loops scenario. The outer loop would set the fileName for the workbook and the inner loop would query the table to create each tabs data set.
David
 

captdkl02

Registered User.
Local time
Today, 17:21
Joined
Dec 4, 2012
Messages
21
David,

I believe you are saying VBA script to read table with two loops? I believe you would still need to use Excel objects to write the data into an Excel workbook with multiple tabs. Am I missing something??

Thank you.

David
 

captdkl02

Registered User.
Local time
Today, 17:21
Joined
Dec 4, 2012
Messages
21
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
 

DavidAtWork

Registered User.
Local time
Today, 21:21
Joined
Oct 25, 2011
Messages
699
David, you have answered your own question as in your code above there is no mention of any Excel objects. The bulk of it is creating the sql you need for each query export, then you're using Docmd.TransferSpreadsheet method.
As for the error, could try declaring your variables not as DAO's ie
Dim qdf As QueryDef
Dim dbs As Database

and then set qdf like this
With dbs
Set qdf = .CreateQueryDef(strQName, strSQL)
End With
 

captdkl02

Registered User.
Local time
Today, 17:21
Joined
Dec 4, 2012
Messages
21
Any help is appreciated to solve runtime error 3061. See info below.

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


Thank you.

David
 

Users who are viewing this thread

Top Bottom