[ Πίνακες ] Εξαγωγή πινάκων σε Excel

[gaz_manos]

Υπάρχει τρόπος να εξάγω όλους τους πίνακες μια βάσης σε μορφή xls με την μία ή πρέπει να εξάγω έναν έναν τους πίνακες;
Ευχαριστώ.

[Meteora]

Καλησπέρα

Εφόσον εργασθείς με VBA μπορείς να γράψεις για κάθε εξαγωγή πίνακα μια γραμμή κώδικα και τα excel να αποθηκεύονται σε όποια διεύθυνση ορίσεις...

Private Sub BtnExport_Click()
    Dim XLFileName$
    XLFileName = "C:\ ArxioXls.xls"

    DoCmd.TransferSpreadsheet _
            TransferType:=acExport, _
            SpreadSheetType:=acSpreadsheetTypeExcel8, _
            TableName:="tblKlados", _
            FileName:=XLFileName, _
            HasFieldNames:=True
End Sub

Στο παραπάνω παράδειγμα εξάγεται ο πίνακας tblKlados σε αρχείο excel...

Για πόσους πίνακες 'μιλάμε' ;

Με εκτίμηση

Νίκος Δ.

[gaz_manos]

Αρχική Δημοσίευση από Meteora

Καλησπέρα

Εφόσον εργασθείς με VBA μπορείς να γράψεις για κάθε εξαγωγή πίνακα μια γραμμή κώδικα και τα excel να αποθηκεύονται σε όποια διεύθυνση ορίσεις...

Private Sub BtnExport_Click()
    Dim XLFileName$
    XLFileName = "C:\ ArxioXls.xls"

    DoCmd.TransferSpreadsheet _
            TransferType:=acExport, _
            SpreadSheetType:=acSpreadsheetTypeExcel8, _
            TableName:="tblKlados", _
            FileName:=XLFileName, _
            HasFieldNames:=True
End Sub

Στο παραπάνω παράδειγμα εξάγεται ο πίνακας tblKlados σε αρχείο excel...

Για πόσους πίνακες 'μιλάμε' ;

Με εκτίμηση

Νίκος Δ.

Μιλάμε για 250 πίνακες.

[Meteora]

Θες κατάλληλη ονομασία πινάκων (ή ερωτημάτων!) και δημιουργία βρόχου...Ούτε στις φυλακές δεν γράφεις τόσες φορές την ίδια γραμμή.

Αυτή είναι η πρώτη μου σκέψη

Νίκος

[gaz_manos]

Βρήκα αυτόν τον κώδικα!!!!!!
Option Compare Database
Option Explicit

Public Sub ExportDatabaseObjects()
On Error GoTo Err_ExportDatabaseObjects

Dim db As Database
'Dim db As DAO.Database
Dim td As TableDef
Dim d As Document
Dim c As Container
Dim i As Integer
Dim sExportLocation As String

Set db = CurrentDb()

sExportLocation = "D:\test\" 'Do not forget the closing back slash! ie: C:\Temp\

For Each td In db.TableDefs 'Tables
If Left(td.Name, 4) <> "MSys" Then
DoCmd.TransferText acExportDelim, , td.Name, sExportLocation & "Table_" & td.Name & ".xls", True
End If
Next td
MsgBox "All database objects have been exported as a text file to " & sExportLocation, vbInformation

Exit_ExportDatabaseObjects:
Exit Sub

Err_ExportDatabaseObjects:
MsgBox Err.Number & " - " & Err.Description
Resume Exit_ExportDatabaseObjects

End Sub

Δείχνει λογικό!!!!!!!!!
Μου βγάζει όμως ένα σφάλμα.
3027- Δεν είναι δυνατή η ενημέρωση.Η βάση δεδομένων ή το αντικείμενο είναι μόνο για ανάγνωση.
Μήπως ξέρει κάποιος τι μπορεί να φταίει;

[Tasos]

Καλησπέρα!
Μάνο δοκίμασε το παρακάτω:

Option Compare Database
Option Explicit

'Εξάγει σε ένα αρχείο Excel με όλους τους πίνακες της βάσης σε χωριστά φύλλα εργασίας
'Θα πρέπει να προσαρμοστεί η διαδρομή "C:\MyFolder\"
Sub Export2Excel_Test1()
    ExportAccessTablesToExcel _
            ExportFolder:="C:\MyFolder\", _
            ExportAllTablesInOneWorkbook:=True, _
            WorkbookName:="MyBook"  ' Προσάρμοσε το όνομα
End Sub

'Εξάγει κάθε πίνακα της βάσης σε νέο βιβλίο εργασίας Excel
'Θα πρέπει να προσαρμοστεί η διαδρομή "C:\MyFolder\"
Sub Export2Excel_Test2()
    ExportAccessTablesToExcel ExportFolder:="C:\MyFolder\"
End Sub

Function ExportAccessTablesToExcel( _
         ExportFolder As String, _
         Optional ExportAllTablesInOneWorkbook As Boolean, _
         Optional WorkbookName As String)

    Dim tdfs As TableDefs
    Dim tdf As TableDef
    Dim strFileName As String
    Set tdfs = CurrentDb.TableDefs
    If Dir(ExportFolder, vbDirectory) = vbNullString Then
        MsgBox "Ο φάκελος δεν είναι διαθέσιμος!", vbExclamation
        Exit Function
    End If
    If ExportAllTablesInOneWorkbook And Len(WorkbookName) Then
        WorkbookName = ExportFolder & WorkbookName & ".xls"
    Else
        ExportAllTablesInOneWorkbook = False
    End If

    For Each tdf In tdfs
        If tdf.Attributes And dbSystemObject Then
        Else
            If ExportAllTablesInOneWorkbook Then
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, tdf.Name, WorkbookName, True
            Else
                strFileName = ExportFolder & tdf.Name & ".xls"
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, tdf.Name, strFileName, True
            End If
        End If
    Next
End Function

Καλή συνέχεια!

Με εκτίμηση

Τάσος

[Meteora]

Δοκίμασε το και σε λιτή έκδοση. Για να δούμε αν θα αντέξει να ...γεμίσουν 250 φύλλα το excel!!!!!

Private Sub btnAllTableExit_Click()
    Dim td As DAO.TableDef, db As DAO.Database
    Set db = CurrentDb()
    For Each td In db.TableDefs
        If Left(td.Name, 4) <> "msys" Then
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
                                      td.Name, "C:\test\xExcelTables.xls", True, td.Name
        End If
    Next
End Sub

Νίκος

[gaz_manos]

Αρχική Δημοσίευση από Tasos

Καλησπέρα!
Μάνο δοκίμασε το παρακάτω:

Option Compare Database
Option Explicit

'Εξάγει σε ένα αρχείο Excel με όλους τους πίνακες της βάσης σε χωριστά φύλλα εργασίας
'Θα πρέπει να προσαρμοστεί η διαδρομή "C:\MyFolder\"
Sub Export2Excel_Test1()
    ExportAccessTablesToExcel _
            ExportFolder:="C:\MyFolder\", _
            ExportAllTablesInOneWorkbook:=True, _
            WorkbookName:="MyBook"  ' Προσάρμοσε το όνομα
End Sub

'Εξάγει κάθε πίνακα της βάσης σε νέο βιβλίο εργασίας Excel
'Θα πρέπει να προσαρμοστεί η διαδρομή "C:\MyFolder\"
Sub Export2Excel_Test2()
    ExportAccessTablesToExcel ExportFolder:="C:\MyFolder\"
End Sub

Function ExportAccessTablesToExcel( _
         ExportFolder As String, _
         Optional ExportAllTablesInOneWorkbook As Boolean, _
         Optional WorkbookName As String)

    Dim tdfs As TableDefs
    Dim tdf As TableDef
    Dim strFileName As String
    Set tdfs = CurrentDb.TableDefs
    If Dir(ExportFolder, vbDirectory) = vbNullString Then
        MsgBox "Ο φάκελος δεν είναι διαθέσιμος!", vbExclamation
        Exit Function
    End If
    If ExportAllTablesInOneWorkbook And Len(WorkbookName) Then
        WorkbookName = ExportFolder & WorkbookName & ".xls"
    Else
        ExportAllTablesInOneWorkbook = False
    End If

    For Each tdf In tdfs
        If tdf.Attributes And dbSystemObject Then
        Else
            If ExportAllTablesInOneWorkbook Then
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, tdf.Name, WorkbookName, True
            Else
                strFileName = ExportFolder & tdf.Name & ".xls"
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, tdf.Name, strFileName, True
            End If
        End If
    Next
End Function

Καλή συνέχεια!

Με εκτίμηση

Τάσος

Δουλεύει πολύ καλά!!!!!!!
Το μόνο ελάττωμα είναι οτι δεν κρατάει την μορφοποίηση.
Αλλά μάλλον δεν μπορούμε να τα θέλουμε όλα δικά μας!!!!!!!!
Πάντως ευχαριστώ πάρα πολύ.

[Tasos]

Μάνο, στον κώδικα σου αντικατέστησε τη συνάρτηση ExportAccessTablesToExcel() με την παρακάτω.

Φυσικά ο χρόνος εκτέλεσης θα είναι μεγαλύτερος αλλά οι μορφοποιήσεις θα διατηρηθούν.

Function ExportAccessTablesToExcel( _
         ExportFolder As String, _
         Optional ExportAllTablesInOneWorkbook As Boolean, _
         Optional WorkbookName As String)

    Const xl2003 = "Excel 97 - Excel 2003 Workbook(*.xls)"
    Dim i As Integer
    Dim SheetCount As Integer
    Dim tdfs As TableDefs
    Dim tdf As TableDef
    Dim strFileName As String
    Dim xl As Object, MainWB As Object, WB As Object, wks As Object

    If Dir(ExportFolder, vbDirectory) = vbNullString Then
        MsgBox "Ο φάκελος δεν είναι διαθέσιμος!", vbExclamation
        Exit Function
    End If

   Set tdfs = CurrentDb.TableDefs

    If ExportAllTablesInOneWorkbook And Len(WorkbookName) Then
        WorkbookName = ExportFolder & WorkbookName & ".xls"
        Set xl = CreateObject("Excel.Application")
        Set MainWB = xl.Workbooks.Add
        SheetCount = MainWB.Sheets.Count
        On Error GoTo ExitHere
        MainWB.SaveAs WorkbookName, 56
    Else
        ExportAllTablesInOneWorkbook = False
    End If

    For Each tdf In tdfs
        If tdf.Attributes And dbSystemObject Then
        Else
            strFileName = ExportFolder & tdf.Name & ".xls"
            DoCmd.OutputTo acOutputTable, tdf.Name, xl2003, strFileName, False
            If ExportAllTablesInOneWorkbook Then
                Set WB = xl.Workbooks.Open(strFileName)
                WB.Sheets(1).Copy After:=MainWB.Sheets(MainWB.Sheets.Count)
                WB.Close False
                Kill strFileName
            End If
        End If
    Next
ExitHere:
    If Err <> 0 Then MsgBox Err & vbLf & Err.Description, vbExclamation
    If Not MainWB Is Nothing Then
        If Not MainWB.Saved Then
            xl.DisplayAlerts = False
            For i = 1 To SheetCount
                MainWB.Sheets(i).Delete
            Next
            MainWB.Save
        End If
        Set MainWB = Nothing
        If Err = 0 Then MsgBox ("OK")
    End If
    If Not xl Is Nothing Then
        xl.Quit
        Set xl = Nothing
    End If
End Function

Καλή συνέχεια

Τάσος

[gaz_manos]

Με τον τρόπο που μου έγραψες θα πρέπει να πάω και να επαναλάβω το ίδιο για όλους τους πίνακες. Σωστά κατάλαβα;
Αν ναι γιατί να το κάνω αυτό και να μην τα κάνω χειροκίνητα?