esportare tabelle da access in excel

Ciao Sandro,

ti propongo ora un altro approccio:

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

      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

    xlApp.DisplayAlerts = False

    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

Ciao Sandro.

Sì, il concetto è quello.

ciao Maurizio,

dopo ore e ore di gran fatica questo il risultato, non so se ho interpretato correttamente il tuo suggerimento....

Definisco due volte il range...mmm....non so se va bene, ma intanto questo è lo step successivo a cui sono giunto: una volta esporto un'altra volta imposto il formato, che dici, brutto?

Altra anomalia che noto è che il campo memo viene formattato come data, sia che ci sia un'esplicito

rRange.NumberFormat = "@", piuttosto che un rRange.NumberFormat = "general".

Vedrò di approfondire meglio anche questo tema.

Ti saluto e ti auguro buon inizio di settimana!!!!

Grazie tante ancora una volta..!

Ciao, Sandro.

Sub tabelleToXls3()

 Dim rst As DAO.Recordset

 Dim tbf As DAO.TableDef

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

 Dim strSql As String

 Dim i As Integer, j As Integer

 Dim lngCount As Long

 Set newExcelIstance = CreateObject("Excel.application")

 Set newWorkBook = newExcelIstance.Workbooks.add

 newWorkBook.Worksheets.add Count:=DCount("name", "Query41") - newWorkBook.Worksheets.Count

 j = 1

 For Each tbf In CurrentDb.TableDefs

       If (tbf.Attributes And dbSystemObject) Then

           Else

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

              If rst.RecordCount > 0 Then

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

                   If i = 0 Then

                     Set newWorkSheet = newWorkBook.Worksheets.Item(j)

                     newWorkSheet.Name = tbf.Name

                   End If

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

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

                   rst.MoveLast

                   Set rRange = newWorkSheet.Cells(2, i + 1)

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

                 lngCount = newWorkSheet.Cells(1, i + 1).CurrentRegion.rows.Count

                 Set rRange = newWorkSheet.Range(newWorkSheet.Cells(2, i + 1), newWorkSheet.Cells(lngCount, i + 1))

                   'Debug.Print newWorkSheet.Cells(1, i + 1).CurrentRegion.Address

                    Select Case FieldTypeName(tbf.Fields(i))

                          Case "Date/Time"

                              rRange.NumberFormat = "dd/mm/yyyy"

                          Case "Currency"

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

                          Case "Single", "Double"

                               rRange.NumberFormat = "#,##0.00"

                          Case "memo"

                                rRange.NumberFormat = "@"

                          End Select

                Next

              End If

              newWorkSheet.Cells.EntireColumn.AutoFit

              j = j + 1

       End If

   Next

   newWorkBook.Close SaveChanges:=True, fileName:=strPath

   MsgBox "file xls con tutte le tabelle in " & strPath, vbInformation, "Informazione"

   Set tbf = Nothing

   Set newExcelIstance = Nothing

   Set newWorkBook = Nothing

   Set newWorkSheet = Nothing

End Sub

Ciao Sandro,

prova a piazzare, dopo:

rRange.CopyFromRecordset ...

questa:

Debug.Print newWorkSheet.Cells(1, 1).CurrentRegion.Address