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-19T09:36:24+00:00

    Chiedo scusa se rispondo solo adesso...

    risolto l'arcano sembra che la causa del malfunzionamento fosse dovuto a dati duplicati

    (quando sono stati eliminati la funzione non si arresta al secondo comando query

    dimenticavo il primo rigo :

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

    l'ho remmata).

    Non so il perché ma mi astengo dall'indagare se poi qualcuno me lo fa capire lo ringrazio anticipatamente

    Per Sandro Peruz: Il termine validazione non ha alcun nesso con ISO UNI e via discorrendo ...

    Ringrazio Maurizio Borrelli e colgo l'occasione per precisare che la mia intenzione è quella di esportare solo alcune tabelle appositamente generate da query e non tutte le tabelle ecco il perché dei giorni della settimana ad ogni modo proverò la routine che hai postato.

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2015-03-18T19:49:00+00:00

    .....il mio mito...! ciao Mauriziooooo...!!! :-)

    un disastro, persa mezza roba per strada...soprattutto il nome dei campi...! non poco direi... :-), D!!!

    Ti dirò, cerco di rendere sempre flessibile il codice al massimo e stavolta credo di avere esagerato..!

    in effetti credo la strada più giusta sia la tua....

    se solo alcune sono le tabelle su cui agire, credo la tua soluzione sia la migliore ;-)

    ho riadattato il codice a una soluzione che avevo postato qualche tempo fa, ed in effetti testandola su northWind noto qualche problema di formattazione strana...

    ora cerco di sistemare...!

    grazie per la dritta...!

    se ho difficoltà, ti posto..!

    ciao, number one!!!

    Sandro.

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2015-03-18T19:21:21+00:00

    Ciao Sandro!

    Forse non ho seguito attentamente il 3d così non ho capito che si vuole salvare *tutte* le tabelle. Mi ha fatto pensare che si volessero solo alcune per via di quei "Lun", "Mar", "Mer", ecc. Perché dire "Ho una serie di tabelle e vorrei esportarle tutte" è un po' diverso da "Vorrei esportare tutte le tabelle". :-D

    Poco male. Se tutte, vale il tuo ciclo su TableDefs, se solo alcune specifiche vale l'array coi nomi che ho usato io, sempre che tali tabelle non abbiano nel nome qualcosa che possa farle considerare un gruppo a sé, tipo un prefisso o come in questo caso i primi tre caratteri dei giorni della settimana. Ecco, può essere un'idea. Poi avevo dimenticato di dare un nome ai fogli... E l'autofit! :-(

    Tu però hai tralasciato i nomi dei campi e, soprattutto, non hai testato con date e numeri. Prova...

    Così la procedura potrebbe diventare:

    Option Compare Database

    Option Explicit

    Public Sub Test2()

    Const cstrProc = "Test2"

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

    Dim strTable    As String

    Dim strFields   As String

    Dim i           As Long

    Dim j           As Long

        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:=7 - .Count

        End With

        For i = 1 To 7

          strTable = Format$(DateSerial(2007, 1, i), "ddd")

          Set xlWsh = xlWbk.Worksheets.Item(i)

          Set rs = CurrentDb.OpenRecordset(strTable, dbOpenTable)

          xlWsh.Name = strTable

          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

        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
  4. Anonimo
    2015-03-18T18:48:16+00:00

    ciao Mikya,

    sostituisci questa riga :

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

    con questa :

    newWorkSheet.cells.EntireColumn.AutoFit

    e rimuovi il Debug.Print tbf.Name lo messo giusti per vedere se il codice agiva sulle tabelle su cui doveva agire.

    Facci sapere!

    ciao, Sandro.

    La risposta è stata utile?

    0 commenti