esportare tabelle da access in excel

Anonimo
2015-03-18T12:08:29+00:00

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

Microsoft 365 e Office | Access | Per la casa | Windows

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
2015-03-24T17:11:44+00:00

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

    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

La risposta è stata utile?

1 persona ha trovato utile questa risposta.
0 commenti

42 risposte aggiuntive

Ordina per: Più recente
Più utili Più recente Meno recente
  1. Anonimo
    2015-03-20T19:07:00+00:00

    ciao Maurizio,

    ultima domanda...! ;-)

    il problema che avevo circa le tabella collegate l'ho risolto vedendo la tua ultima release....

    tbf.recordcount restituisce il numero di records corretto solo se tbf è un oggetto che contiene una tabella locale, se collegata invece no...

    Aprendo un recordset su ogni tabella, indipendentemente che sia locale o collegate non ottengo l'errore che si manifestava in precedenza.

    in pratica questo :

    Set rst = DBEngine(0)(0).OpenRecordset(tbf.Name, dbOpenDynaset)

                      Set rRange = newWorkSheet.Range(newWorkSheet.cells(2, i + 1), newWorkSheet.cells(rst.RecordCount + 1, i + 1))

    è ok e esporta anche la tabella collegata,

    invece :

           Set rRange = newWorkSheet.Range(newWorkSheet.cells(2, i + 1), newWorkSheet.cells(Tbf.RecordCount + 1, i + 1))

    se tbf rappresenta una tabella collegata tbf.recordcount restutuisce -1.

    non capisco la ragione....che cosa mi sfugge ora?

    un saluto, buona serata e grazie ancora!

    ciao, Sandro.

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2015-03-20T14:36:16+00:00

    nella funzione che posti GetTableDefsCount dal nome credo abbia il compito di restituire il numero di tabelle del database, credo tralasciata per una semplice dimenticanza.

    Effettivamente!...

    Eccola:

    Public Function GetTableDefsCount(db As DAO.Database)

    Dim td  As DAO.TableDef

    Dim i   As Long

        For Each td In db.TableDefs

          If (td.Attributes And dbSystemObject) = False Then i = i + 1

        Next

        GetTableDefsCount = i

        Set td = Nothing

    End Function

    -oppure-

    Public Function GetTableDefsCount(db As DAO.Database)

    Dim i As Long

    Dim j As Long

        With db.TableDefs

          For i = 0 To .Count - 1

            If (.Item(i).Attributes And dbSystemObject) = False Then j = j + 1

          Next

        End With

        GetTableDefsCount = j

    End Function

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2015-03-20T13:12:19+00:00

    ciao Maurizio,

    grazie innanzi tutto per dare seguito al post ! :-)

    il statement sql è migliore infatti con il mio ho dovuto sottrarre 1 dal conteggio perché mi compariva un oggetto che non centra nulla con le tabelle...

    Non ho incluso nel mio statement l'object type  6 -tabelle collegate-perché ieri sera non sono riuscito a fare girare l'esportazione per le tabella collegate.

    la strPath è una dimenticanza nell'ultimo, nel post precedente  la dichiarazione era presente :

     Option Explicit

    Private Const StrPath As String = "C:\TuoPathXls\tuoFile.xlsx" ' da modifcare TuoPathXls e tuoFile.

    Osservazione corretta circa la non gestione anche dell'orario...vedo di rimediare la formattazione.

    nella funzione che posti GetTableDefsCount dal nome credo abbia il compito di restituire il numero di tabelle del database, credo tralasciata per una semplice dimenticanza.

    Anche se la scrivo semplicemente così :

    Public Function GetTableDefsCount(db As DAO.Database) As Integer

     GetTableDefsCount = db.TableDefs.Count

     End Function

    e la if esclude le tabelle di sistema i fogli creati sono troppi...mi interessava capire se la tua sub estrae anche le tabelle collegate e le estrae, credo però la GetTableDefsCount debba essere rivisitata...

    in serata me la studio meglio...!

    ciao e grazie, Sandro.

    La risposta è stata utile?

    0 commenti
  4. Anonimo
    2015-03-20T11:45:40+00:00

    Ciao Sandro Peruz,

    quella Query41 è un po' perigliosa... Niente tabelle collegate e probabili oggetti indesiderati. Potrebbe andar meglio come:

    SELECT T.Name

    FROM MSysObjects AS T

    WHERE Left([Name],4)<>"Msys" AND ((T.Type=1 AND T.Flags=0) OR T.Type=6);

    (testata con Access 2013) ma comunque io non andrei a frugare in MSysObjects, che chissà cosa ci mettono di versione in versione.

    La variabile strPath non sembra definita, o manca qualcosa al tuo copincolla.

    Escludi che i campi data possano avere anche un orario?

    Io ho provato così, senza curarmi dei formati dei campi, per ora, Esporta anche tabelle collegate. Vedi se funziona, grazie!

    Public Sub Test3()

    Const cstrProc = "Test3"

    On Error GoTo ErrH

    Dim e As Long

    Const cstrXlsFullPath = "D:\Percorso\Test1" ' <--- Personalizzare

    Dim xlApp         As Object 'Excel.Application

    Dim xlWbk         As Object 'Excel.Workbook

    Dim xlWsh         As Object 'Excel.Worksheet

    Dim blnNotRunning As Boolean

    Dim db  As DAO.Database

    Dim td  As DAO.TableDef

    Dim rs  As DAO.Recordset

    Dim strFields   As String

    Dim i           As Long

    Dim j           As Long

        Set db = CurrentDb

        On Error Resume Next

        Set xlApp = GetObject(Class:="Excel.Application")

        e = Err.Number

        On Error GoTo ErrH

        If e Then Set xlApp = CreateObject(Class:="Excel.Application")

        Set xlWbk = xlApp.Workbooks.Add

        With xlWbk.Worksheets

          .Add Count:=GetTableDefsCount(db) - .Count

        End With

        For Each td In db.TableDefs

          If (td.Attributes And dbSystemObject) = False Then

            i = i + 1

            Set xlWsh = xlWbk.Worksheets.Item(i)

            Set rs = db.OpenRecordset(td.Name, dbOpenSnapshot)

            xlWsh.Name = td.Name

            strFields = ""

            With rs.Fields

              For j = 0 To .Count - 1

                strFields = strFields & "," & .Item(j).Name

              Next

            End With

            With xlWsh

              .Range("A1").Resize(1, j) = Split(Mid$(strFields, 2), ",")

              .Range("A2").CopyFromRecordset rs

              .Columns.AutoFit

            End With

            rs.Close

          End If

        Next

        MsgBox "Fatto!"

    ExtP:

        On Error Resume Next

        rs.Close

        Set rs = Nothing

        xlApp.DisplayAlerts = False

        xlWbk.Close SaveChanges:=True, FileName:=cstrXlsFullPath

        If blnNotRunning Then xlApp.Quit

        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