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-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 Nessun commento
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 Nessun commento
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 Nessun commento
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 Nessun commento