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-19T15:32:25+00:00

    ciao Maurizio,

    grazie a te per la risposta ed il tempo che mi/ci dedichi.

    la seconda domanda, si, vero, soprattutto in presenza di molti fogli con la necessità di filltrare essere costretti ad eliminare la riga a mano è proprio una perdita di tempo.

    Nel db di Northwind che uso per sperimentare ho oltre 20 tabelle, quindi si, colgo al volo il consiglio.

    grazie.

    per la prima invece...eh....bella sfida....e bella domanda...mi verrebbe da pensare di testare a fine esportazione quale è il nome di default che viene assegnato da Excel al foglio/fogli vedere quanti ce ne sono e cancellarli....mi sembra la cosa più intelligente....in serata tento questo approccio...

    Non mi dire però se è corretto o meno...

    se fallisco chiedo aiuto ancora una volta..:!

    grazie e un salutone.

    Sandro.

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2015-03-19T14:09:40+00:00

    Grazie della fiducia, Sandro. :-)

    Mi sembra bene! Più tardi guarderò meglio. Gira e fa quel che deve fare.

    Due cose:

    For i = 1 To 3

         newWorkBook.Sheets("foglio" & i).Delete

    Next

    Le mie cartelle di lavoro nascono con un solo foglio (che potrebbe anche non chiamarsi "FoglioN" Per esempio se la lingua non è italiano). Come la mettiamo? :-)

    E l'altra, secondo me da evitare assolutamente, è la riga vuota fra i nomi dei campi e i dati relativi. Togli, per esempio, la possibilità di fare ordinamenti usando i nomi dei campi invece del nome delle colonne.

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2015-03-19T13:38:05+00:00

    ciao Maurizio, buongiorno a te

    ho migliorato secondo me l'esportazione formattando date e numeri,

    Sempre nell'ottica di esportare tutte le tabelle e visualizzare il nome dei campi...

    Ancora qualcosa non mi quadra però con i valori numerici non formattati sempre in modo corretto...mi daresti una mano a capire come mai?

    grazie e buona giornata a te...

    Sandro

    ps.Sono un po' OT ma spero non troppo....

    Sub tabelleToXls2()

    Dim tbf As DAO.TableDef

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

    Dim rst As DAO.Recordset

    Dim strSql As String

    Dim i As Integer

    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

                 For i = 0 To tbf.Fields.Count - 1

                     newWorkSheet.cells(1, i + 1) = tbf.Fields(i).Name

                     strSql = "select [" & tbf.Fields(i).Name & "] from [" & tbf.Name & "]"

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

                     Select Case FieldTypeName(tbf.Fields(i))

                            Case "Date/Time"

                                rRange.NumberFormat = "mm/dd/yyyy"

                            Case "Currency"

                                rRange.NumberFormat = "$ #,##0.00"

                            Case "Single", "Double"

                                 rRange.NumberFormat = "#,##0.00"

                     End Select

                     rRange.CopyFromRecordset DBEngine(0)(0).OpenRecordset(strSql, dbOpenDynaset)

                Next

                 newWorkSheet.cells.EntireColumn.AutoFit

         End If

     Next

     newExcelIstance.Visible = True

    For i = 1 To 3

         newWorkBook.Sheets("foglio" & i).Delete

    Next

     Set tbf = Nothing

     Set newExcelIstance = Nothing

     Set newWorkBook = Nothing

     Set newWorkSheet = Nothing

    End Sub

    Private Function FieldTypeName(fld As DAO.Field) As String

        'Purpose: Converts the numeric results of DAO Field.Type to text.

        Dim strReturn As String    'Name to return

        Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.

            Case dbBoolean: strReturn = "Yes/No"            ' 1

            Case dbByte: strReturn = "Byte"                 ' 2

            Case dbInteger: strReturn = "Integer"           ' 3

            Case dbLong                                     ' 4

                If (fld.Attributes And dbAutoIncrField) = 0& Then

                    strReturn = "Long Integer"

                Else

                    strReturn = "AutoNumber"

                End If

            Case dbCurrency: strReturn = "Currency"         ' 5

            Case dbSingle: strReturn = "Single"             ' 6

            Case dbDouble: strReturn = "Double"             ' 7

            Case dbDate: strReturn = "Date/Time"            ' 8

            Case dbBinary: strReturn = "Binary"             ' 9 (no interface)

            Case dbText                                     '10

                If (fld.Attributes And dbFixedField) = 0& Then

                    strReturn = "Text"

                Else

                    strReturn = "Text (fixed width)"        '(no interface)

                End If

            Case dbLongBinary: strReturn = "OLE Object"     '11

            Case dbMemo                                     '12

                If (fld.Attributes And dbHyperlinkField) = 0& Then

                    strReturn = "Memo"

                Else

                    strReturn = "Hyperlink"

                End If

            Case dbGUID: strReturn = "GUID"                 '15

            'Attached tables only: cannot create these in JET.

            Case dbBigInt: strReturn = "Big Integer"        '16

            Case dbVarBinary: strReturn = "VarBinary"       '17

            Case dbChar: strReturn = "Char"                 '18

            Case dbNumeric: strReturn = "Numeric"           '19

            Case dbDecimal: strReturn = "Decimal"           '20

            Case dbFloat: strReturn = "Float"               '21

            Case dbTime: strReturn = "Time"                 '22

            Case dbTimeStamp: strReturn = "Time Stamp"      '23

            'Constants for complex types don't work prior to Access 2007 and later.

            Case 101&: strReturn = "Attachment"         'dbAttachment

            Case 102&: strReturn = "Complex Byte"       'dbComplexByte

            Case 103&: strReturn = "Complex Integer"    'dbComplexInteger

            Case 104&: strReturn = "Complex Long"       'dbComplexLong

            Case 105&: strReturn = "Complex Single"     'dbComplexSingle

            Case 106&: strReturn = "Complex Double"     'dbComplexDouble

            Case 107&: strReturn = "Complex GUID"       'dbComplexGUID

            Case 108&: strReturn = "Complex Decimal"    'dbComplexDecimal

            Case 109&: strReturn = "Complex Text"       'dbComplexText

            Case Else: strReturn = "Field type " & fld.Type & " unknown"

        End Select

        FieldTypeName = strReturn

    End Function

    La risposta è stata utile?

    0 commenti
  4. Anonimo
    2015-03-19T11:51:20+00:00

    Ciao Mykia55,

    un paio di domande:

    1. Ciò che vuoi esportare sono tabelle o risultati di query?
    2. I nomi reali di ciò che vuoi esportare sono effettivamente "Lun", "Mar", ecc?

    La risposta è stata utile?

    0 commenti