esportare tabelle da access in excel

Anonimo

Ho una serie di tabelle in access e vorrei esportarle tutte in un unico file Excel (cartella Excel con all'interno i vari fogli che corrisponderanno alle tabelle di cui sopra)... l'unica cosa che riesco ad ottenere è che viene trasferita sempre e solo il primo foglio della mia cartella di lavoro...

di seguito il codice che utilizzo:

Function Esporto() DoCmd.TransferSpreadsheet acExport, 8, "Lun", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False, "B1:o12000" False, "B1:o12000"Set xl = CreateObject("Excel.Application") ' dove sSource = path completo del tuo file .xls sSource = "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls"With xl ' .Workbooks.Add .Workbooks.Open sSource ' .Sheets(sSheet).Activate .Visible = True End With End Function

nel mio caso la cartella è "validazione.xls" ed i fogli di lavoro sono divisi per giorni della settimana (lun, mar, ecc

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Sandro!

Posto di nuovo il codice perché ho l'impressione che non ci siamo capiti riguardo la posizione dei due ScreenUpdating. Se sbaglio, scusami.

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

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

0 commenti

42 risposte aggiuntive

Anonimo

2015-03-23T18:05:36+00:00

Ciao Sandro.

Vedi se migliora (leggermente) modificando questi due blocchi di codice:

1)

    With xlApp

      If blnNotRunning And cblnShow Then .Visible = True

      .ScreenUpdating = False               ' <---------

      Set xlWbk = .Workbooks.Add

    End With

2)

    With xlApp

      .ScreenUpdating = True                ' <---------

      .DisplayAlerts = False

    End With
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2015-03-23T17:26:46+00:00

ciao Maurizio,

stavolta rispondo di getto...! :-) l'ho solo provata..!

Non vedo alcun richiamo nel codice alla formattazione in più hai usato ado...

Mi aspettavo tempi di esecuzione più lughi rispetto alla mia routine, ed invece tutto funziona a puntino, formattazione inclusa...!

Inoltre, ma cosa vuoi che sia...

la mia routine ci mette oltre 11,000 millesecondi la tua meno di 5000....cosa vuoi che sia, è solo tre volte più veloce...! :-(, ma anche ad occhio si nota la velocità della luce, e per questo l'ho voluta misurare...

sono basito...!

se non fossi a casa andrei a casa...! troppo superBravissimo...! devo ammettere che al tuo livello sia molto difficile per me anche solamente avvicinarsi...! anni luce distante...!

ora me la studio...!

grazie, grazie e ancora grazie..!!!! ke mito...!

Ciao, Sandro.
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2015-03-23T16:12:01+00:00

Ciao Sandro,

ti propongo ora un altro approccio:

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

      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

    xlApp.DisplayAlerts = False

    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
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2015-03-23T03:18:13+00:00

Ciao Sandro.

Sì, il concetto è quello.
La risposta è stata utile?

0 commenti Nessun commento