Forum

Αναζήτηση στο ms-office.gr

Πάμε!
ms-office.gr > Forum > Microsoft Access > Access - Ερωτήσεις / Απαντήσεις > [ Πίνακες ] Εξαγωγή πινάκων σε Excel

Access - Ερωτήσεις / Απαντήσεις Access + VBA... Εδώ δεν υπάρχουν όρια!

Απάντηση στο θέμα

 

Εργαλεία Θεμάτων Τρόποι εμφάνισης
  #11  
Παλιά 04-06-13, 22:30
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή

Παράθεση:
Αρχική Δημοσίευση από 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
Καλή συνέχεια!

Με εκτίμηση

Τάσος
Δουλεύει πολύ καλά!!!!!!!
Το μόνο ελάττωμα είναι οτι δεν κρατάει την μορφοποίηση.
Αλλά μάλλον δεν μπορούμε να τα θέλουμε όλα δικά μας!!!!!!!!
Πάντως ευχαριστώ πάρα πολύ.
Απάντηση με παράθεση
  #12  
Παλιά 05-06-13, 01:15
Το avatar του χρήστη Tasos
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 2016, Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.237
Προεπιλογή

Μάνο, στον κώδικα σου αντικατέστησε τη συνάρτηση 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
Καλή συνέχεια

Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών

Τελευταία επεξεργασία από το χρήστη Tasos : 05-06-13 στις 03:33.
Απάντηση με παράθεση
Απάντηση στο θέμα

Εργαλεία Θεμάτων
Τρόποι εμφάνισης

Δικαιώματα - Επιλογές
Δε μπορείτε να δημοσιεύσετε νέα μηνύματα
Δε μπορείτε να δημοσιεύσετε απαντήσεις
Δεν μπορείτε να επισυνάψετε αρχεία
Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας

Ο κώδικας ΒΒ είναι σε λειτουργία
Τα Smilies είναι σε λειτουργία
Ο κώδικας [IMG] είναι σε λειτουργία
Ο κώδικας HTML είναι εκτός λειτουργίας
Trackbacks are εκτός λειτουργίας
Pingbacks are εκτός λειτουργίας
Refbacks are εκτός λειτουργίας


Παρόμοια Θέματα

Θέμα Δημιουργός Forum Απαντήσεις Τελευταίο Μήνυμα
Βοήθεια γιά Εξαγωγή σέ Excel pansyr Word - Ερωτήσεις / Απαντήσεις 0 15-02-16 17:30
[ Πίνακες ] Εξαγωγή πίνακα σε excel markosv Access - Ερωτήσεις / Απαντήσεις 2 23-11-11 18:01
ΕΞΑΓΩΓΗ ΣΕ ΑΡΧΕΙΟ EXCEL ΤΖΙΜΗΣ Access - Ερωτήσεις / Απαντήσεις 1 01-04-11 15:42
Εξαγωγή Report σε excel iondep Access - Ερωτήσεις / Απαντήσεις 5 03-11-10 20:31
Εξαγωγή σε Excel amy Access - Ερωτήσεις / Απαντήσεις 5 08-02-10 10:57


Η ώρα είναι 05:51.