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-18T18:16:47+00:00

    ciao Mykia55,

    grazie per il chiarimento.

    con questa sub, esporti tutte le tabelle tranne quelle di sistema in un nuovo file di Excel, ti resta solo da salvarlo e rinominarlo.

    la routine è in latebinding quindi non hai necessità di riferimenti di sorta.

    ha un limite la seguente istruzione :

    newWorkSheet.Columns(Chr(65) & ":" & Chr(90)).autofit

    in pratica "autofitti" se mi passi il termine le colonne dalla A alla Z.....

    mi intriga capire come ottimizzare questo aspetto....

    in caso chiedo a Maurizio se non ci riesco...visto che oggi è passato di qua... :-)

    Ciao, Sandro.

    Ps. non mi hai detto nulla circa l'attinenza del termine validazione, centra qualcosa con l'iso 9001:2008 ?

    Sub tabelleToXls()

    Dim tbf As DAO.TableDef

    Dim newWorkBook As Object, newWorkSheet As Object, newExcelIstance As Object, rRange As Object

    Set newExcelIstance = CreateObject("Excel.application")

    Set newWorkBook = newExcelIstance.Workbooks.add

    For Each tbf In CurrentDb.TableDefs

        If (tbf.Attributes And dbSystemObject) Then

            Else

                Debug.Print tbf.Name

                Set newWorkSheet = newWorkBook.Worksheets.add

                newWorkSheet.Name = tbf.Name

                newExcelIstance.Visible = True

                Set rRange = newWorkSheet.Range(newWorkSheet.cells(3, 1), newWorkSheet.cells(tbf.RecordCount + 2, tbf.Fields.Count))

                rRange.CopyFromRecordset DBEngine(0)(0).OpenRecordset(tbf.Name, dbOpenTable)

                newWorkSheet.Columns(Chr(65) & ":" & Chr(90)).autofit

        End If

    Next

    Set tbf = Nothing

    Set newExcelIstance = Nothing

    Set newWorkBook = Nothing

    Set newWorkSheet = Nothing

    End Sub

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2015-03-18T17:02:20+00:00

    Ciao Mykia55,

    visto che alla fine usi Excel prova così:

    Option Compare Database

    Option Explicit

    Public Sub Test1()

    Const cstrTitle = "Test1"

    On Error GoTo ErrH

    Dim e As Long

    Const cstrTables = "Tabella1,Tabella2,Tabella3" ' <--- Personalizzare

    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 rs As DAO.Recordset

    Dim strTables() As String

    Dim strFields   As String

    Dim i           As Long

    Dim j           As Long

        strTables = Split(cstrTables, ",")

        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

        For i = 0 To UBound(strTables)

          Set xlWsh = xlWbk.Worksheets.Add

          Set rs = CurrentDb.OpenRecordset(strTables(i), dbOpenTable)

          strFields = ""

          With rs.Fields

            For j = 0 To .Count - 1

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

            Next

          End With

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

          xlWsh.Range("A2").CopyFromRecordset rs

          rs.Close

        Next

    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, cstrTitle

        End With

        Resume ExtP

    End Sub

    EDIT:

    Scusate, ho fatto delle correzioni al volo.

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2015-03-18T16:44:03+00:00

    Function Esporto()

    DoCmd.TransferSpreadsheet acExport, 8, "Validazione", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False, "B1:o12000"

    DoCmd.TransferSpreadsheet acExport, 8, "Lun", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False

    DoCmd.TransferSpreadsheet acExport, 8, "Mar", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False

    DoCmd.TransferSpreadsheet acExport, 8, "Mer", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False

    DoCmd.TransferSpreadsheet acExport, 8, "Gio", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False

    DoCmd.TransferSpreadsheet acExport, 8, "Ven", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False

    DoCmd.TransferSpreadsheet acExport, 8, "Sab", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False

    DoCmd.TransferSpreadsheet acExport, 8, "Dom", "C:\Documents and Settings\All Users\Desktop\Validazione\validazione.xls", False

    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

    questa è la funzione che riesce ad esportare correttamente i dati ma solo al secondo invito

    mi spiego: si blocca dicendo che mar già esiste (e non è vero) rilanciando di nuovo mi crea un mar1 con i dati corretti e un mar vuoto e questo lo fa per il qualunque sia il file sulla seconda riga

    (mer o gio ecc.)

    La risposta è stata utile?

    0 commenti
  4. Anonimo
    2015-03-18T16:18:30+00:00

    Una soluzione potrebbe essere un Kill del file excell prima delle export.

    L'alternativa è data dall'automazione di Excell .

    Mimmo

    La risposta è stata utile?

    0 commenti