ciao Any,
I may suggest the following code written by an Italian MVP, which allows you to export in one workbook each table in each worksheet :
this is the italian 3d:
http://answers.microsoft.com/it-it/office/forum/office\_2013\_release-access/esportare-tabelle-da-access-in-excel/3f9b3241-6084-418b-93b2-a4a4d44cd0f8
Remember to customize the path..!
I hope this helps!
ciao, Sandro.
Option Compare Database
Option Explicit
#Const DevMode = 0
Public Sub Test4()
Const cstrProc = "Test4"
On Error GoTo ErrH
Dim e As Long
' --- Personalizzare -------------------- >
'
Const cstrXlsFullPath = "D:\Percorso\Test1"
Const cblnShow = False
' --------------------------------------- <
Const cstrXlClass = "Excel.Application"
Const cstrFullName = "<FullName>"
Const cstrCnn = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0" _
& ";Data Source=" & cstrFullName _
& ";Mode=Read;"
Dim dbp As Access.CurrentProject
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
#If DevMode Then
Dim xlApp As Excel.Application
Dim xlWbk As Excel.Workbook
Dim xlWsh As Excel.Worksheet
Dim xlQry As Excel.QueryTable
#Else
Const xlCmdTable = 3
Dim xlApp As Object
Dim xlWbk As Object
Dim xlWsh As Object
Dim xlQry As Object
#End If
Dim blnNotRunning As Boolean
Dim strCnn As String
Dim strTable As String
Dim lngTable As Long
With Application
Set dbp = .CurrentProject
Set dbs = .CurrentDb
End With
strCnn = Replace(cstrCnn, cstrFullName, dbp.FullName)
Debug.Print strCnn
On Error Resume Next
Set xlApp = GetObject(Class:=cstrXlClass)
e = Err.Number
On Error GoTo ErrH
If e Then
blnNotRunning = True
Set xlApp = CreateObject(Class:=cstrXlClass)
End If
With xlApp
If blnNotRunning And cblnShow Then .Visible = True
.ScreenUpdating = False
Set xlWbk = .Workbooks.Add
End With
With xlWbk.Worksheets
.Add Count:=GetTableDefsCount(dbs) - .Count
End With
For Each tdf In dbs.TableDefs
If (tdf.Attributes And dbSystemObject) = False Then
lngTable = lngTable + 1
strTable = tdf.Name
Set xlWsh = xlWbk.Worksheets.Item(lngTable)
With xlWsh
.Name = strTable
Set xlQry = .QueryTables.Add(Connection:=strCnn _
, Destination:=.Range("A1"))
End With
With xlQry
.CommandType = xlCmdTable
.CommandText = strTable
.AdjustColumnWidth = True
.FieldNames = True
.Refresh
.Delete
End With
Set xlQry = Nothing
End If
Next
MsgBox "Fatto!"
ExtP:
On Error Resume Next
Set tdf = Nothing
Set dbs = Nothing
Set dbp = Nothing
With xlApp
.ScreenUpdating = True
.DisplayAlerts = False
End With
xlWbk.Close SaveChanges:=True _
, FileName:=cstrXlsFullPath
If cblnShow Then
xlApp.Visible = True
Else
If blnNotRunning Then xlApp.Quit
End If
Set xlQry = Nothing
Set xlWsh = Nothing
Set xlWbk = Nothing
Set xlApp = Nothing
Exit Sub
ErrH:
With Err
MsgBox "ERR#" & CStr(.Number) _
& vbNewLine & .Description _
, vbOKOnly Or vbCritical, cstrProc
End With
Resume ExtP
End Sub